Printer for expressions

packages.dhall

@@ -36,6 +36,40 @@ let overrides =
           , "tuples"
           ]
         }
+      , dodo-printer =
+        { version = "v2.2.1"
+        , repo = "https://github.com/natefaubion/purescript-dodo-printer"
+        , dependencies =
+          [ "aff"
+          , "ansi"
+          , "arrays"
+          , "avar"
+          , "console"
+          , "control"
+          , "effect"
+          , "either"
+          , "exceptions"
+          , "foldable-traversable"
+          , "integers"
+          , "lists"
+          , "maybe"
+          , "minibench"
+          , "newtype"
+          , "node-buffer"
+          , "node-child-process"
+          , "node-fs"
+          , "node-os"
+          , "node-path"
+          , "node-process"
+          , "node-streams"
+          , "parallel"
+          , "partial"
+          , "prelude"
+          , "safe-coerce"
+          , "strings"
+          , "tuples"
+          ]
+          }
       }
 
 in  upstream // overrides

spago.dhall

@@ -11,6 +11,7 @@
   , "console"
   , "control"
   , "debug"
+  , "dodo-printer"
   , "effect"
   , "either"
   , "enums"

src/Components/Explorer/FunctionFilter.purs

@@ -110,7 +110,6 @@ countParams :: Type -> Int
 countParams = case _ of
   TypeApply x xs -> sum $ map countParams (Array.cons x xs)
   ArrowTypeApply xs -> sum $ map countParams xs
-  UnionTypeApply xs -> sum $ map countParams xs
   ArrayTypeApply x -> countParams x
   TypeParam' _ -> one
   _ -> zero
@@ -129,8 +128,6 @@ findParamReplacements = case _ of
       $ Array.zip (Array.cons x xs) (Array.cons y ys)
   ArrowTypeApply xs /\ ArrowTypeApply ys ->
     Map.unions $ map findParamReplacements $ Array.zip xs ys
-  UnionTypeApply xs /\ ArrowTypeApply ys ->
-    Map.unions $ map findParamReplacements $ Array.zip xs ys
   ArrayTypeApply x /\ ArrayTypeApply y ->
     findParamReplacements (x /\ y)
   TypeParam' param /\ targetType ->
@@ -141,7 +138,6 @@ replaceParams :: Map TypeParam Type -> Type -> Type
 replaceParams replacements = case _ of
   TypeApply x xs -> TypeApply (replace x) (map replace xs)
   ArrowTypeApply xs -> ArrowTypeApply $ map replace xs
-  UnionTypeApply xs -> UnionTypeApply $ map replace xs
   ArrayTypeApply x -> ArrayTypeApply $ replace x
   TypeParam' param
     | Just targetType <- Map.lookup param replacements -> targetType

src/Interpreter/Formula.purs

@@ -62,7 +62,7 @@ extractCells (RightOpSection body _) =
 
 extractCells (WhereExpr fnBody bindings) =
   extractCells fnBody <>
-    foldMap (extractCells <<< (\(FnDef _ _ _ _ body) -> body)) bindings
+    foldMap (extractCells <<< (case _ of (FnDef _ _ _ _ body) -> body)) bindings
 
 extractCells (CondExpr conds) =
   foldMap extractCellsFromGuardedBody conds

src/Parser/Type.purs

@@ -28,13 +28,10 @@ type' = defer \_ -> complexType <|> atom
   arrow = defer \_ -> ArrowTypeApply <$> multipleSepBy (isToken "->")
     (atom <|> betweenParens complexType)
 
-  union = defer \_ -> UnionTypeApply <$> multipleSepBy (isToken "|")
-    (atom <|> betweenParens complexType)
-
   array = defer \_ -> ArrayTypeApply <$> betweenSquare type'
 
   typeVar' = TypeVar' <$> typeVar
   typeParam' = TypeParam' <$> typeParam
 
-  complexType = defer \_ -> arrow <|> union
+  complexType = defer \_ -> arrow
   atom = defer \_ -> typeApply <|> typeVar' <|> typeParam' <|> array

src/Printer/Common.purs

@@ -0,0 +1,64 @@
+module App.Printer.Common where
+
+import FatPrelude
+
+import App.Components.Spreadsheet.Cell (Cell, CellValue)
+import App.SyntaxTree.Common (Module, QVar, QVarOp, Var, VarOp)
+import Data.Array as Array
+import Dodo (Doc, break, enclose, foldWithSeparator, indent, lines, text, (<+>))
+
+cell :: forall a. Cell -> Doc a
+cell = text <<< show
+
+cellValue :: forall a. CellValue -> Doc a
+cellValue = text <<< show
+
+var :: forall a. Var -> Doc a
+var = text <<< show
+
+varOp :: forall a. VarOp -> Doc a
+varOp = text <<< show
+
+module' :: forall a. Module -> Doc a
+module' = text <<< show
+
+qVar :: forall a. QVar -> Doc a
+qVar = text <<< show
+
+qVarOp :: forall a. QVarOp -> Doc a
+qVarOp = text <<< show
+
+encloseTuple :: forall a. Array (Doc a) -> Doc a
+encloseTuple xs
+  | length xs > 1 = encloseArgs xs
+  | otherwise = unsafeFromJust $ Array.head xs
+
+encloseList :: forall f a. Foldable f => f (Doc a) -> Doc a
+encloseList = encloseSquare <<< foldWithSeparator (text ",")
+
+encloseArgs :: forall f a. Foldable f => f (Doc a) -> Doc a
+encloseArgs = encloseParens <<< foldWithSeparator (text ",")
+
+encloseContext :: forall f a. Foldable f => f (Doc a) -> Doc a
+encloseContext =
+  encloseCurly <<< surroundDoc break <<< indent <<< lines
+
+encloseParens :: forall a. Doc a -> Doc a
+encloseParens = enclose (text "(") (text ")")
+
+encloseSquare :: forall a. Doc a -> Doc a
+encloseSquare = enclose (text "[") (text "]")
+
+encloseCurly :: forall a. Doc a -> Doc a
+encloseCurly = enclose (text "{") (text "}")
+
+surroundDoc :: forall a. Doc a -> Doc a -> Doc a
+surroundDoc x = enclose x x
+
+zipWithInfixs
+  :: forall a b c. (a -> Doc c) -> (b -> Doc c) -> Array a -> Array b -> Doc c
+zipWithInfixs infixFn valFn infixs vals =
+  fold $ Array.cons (valFn $ unsafeFromJust $ Array.head vals)
+    ( Array.zipWith (\x y -> infixFn x <+> valFn y) infixs
+        (fold $ Array.tail vals)
+    )

src/Printer/FnDef.purs

@@ -0,0 +1,80 @@
+module App.Printer.FnDef where
+
+import FatPrelude hiding (guard)
+
+import App.Printer.Common (cell, cellValue, encloseArgs, encloseContext, encloseList, encloseParens, encloseSquare, encloseTuple, qVar, qVarOp, surroundDoc, var, varOp, zipWithInfixs)
+import App.Printer.Pattern (pattern')
+import App.Printer.Type (type')
+import App.SyntaxTree.FnDef (CaseBinding(..), FnBody(..), FnDef(..), Guard(..), GuardedFnBody(..), MaybeGuardedFnBody(..), OpDef(..), PatternGuard(..))
+import Data.Array as Array
+import Data.String.Utils as String
+import Dodo (Doc, break, foldWithSeparator, text, (<%>), (<+>), (</>))
+
+opDef :: forall a. OpDef -> Doc a
+opDef = case _ of
+  OpDef x y z t -> varOp x
+    <+> text "="
+    <+> qVar y
+    <+> text (show z <> show t)
+
+fnDef :: forall a. FnDef -> Doc a
+fnDef = case _ of
+  FnDef x ys z t v -> var x
+    <+> encloseArgs (map printParam ys)
+    <+> fold ((text ":" <+> _) <<< type' <$> z)
+    <+> text "="
+    <+> fold (((break <+> text "//") <+> _) <<< text <$> String.lines t)
+    <%> fnBody v
+  where
+  printParam (x /\ y) = fold $ Array.cons (var x)
+    (Array.fromFoldable ((text ":" <+> _) <<< type' <$> y))
+
+fnBody :: forall a. FnBody -> Doc a
+fnBody = case _ of
+  FnApply x ys -> fnBody x </> encloseArgs (map fnBody ys)
+  Recur xs -> text "recur" </> encloseArgs (map fnBody xs)
+  LambdaFn xs y -> (encloseTuple (map var xs) <+> text "->") </> fnBody y
+  InfixFnApply xs ys -> zipWithInfixs qVarOp fnBody xs ys
+  LeftOpSection x y -> text "_" <+> qVarOp x <+> fnBody y
+  RightOpSection x y -> fnBody x <+> qVarOp y <+> text "_"
+  WhereExpr x ys -> fnBody x <+> text "where"
+    <+> encloseContext ((text "|" <+> _) <<< fnDef <$> ys)
+  CondExpr xs -> text "cond"
+    <+> encloseContext (guardedFnBody (text "=>") <$> xs)
+  SwitchExpr x ys -> text "switch" <+> encloseParens (fnBody x)
+    <+> encloseContext ((text "|" <+> _) <<< caseBinding <$> ys)
+  CellMatrixRange x y -> encloseSquare
+    $ surroundDoc (text "||") (cell x <+> text ".." <+> cell y)
+  CellArrayRange x y -> encloseSquare
+    $ surroundDoc (text "|") (cell x <+> text ".." <+> cell y)
+  ArrayRange x y -> encloseSquare
+    (fnBody x <+> text ".." <+> fnBody y)
+  Array' xs -> encloseList $ map fnBody xs
+  FnVar x -> qVar x
+  FnOp x -> qVarOp x
+  Cell' x -> cell x
+  CellValue' x -> cellValue x
+  Object' _ -> mempty
+
+caseBinding :: forall a. CaseBinding -> Doc a
+caseBinding = case _ of
+  CaseBinding x y -> pattern' x </> maybeGuardedFnBody (text "=>") y
+
+maybeGuardedFnBody :: forall a. Doc a -> MaybeGuardedFnBody -> Doc a
+maybeGuardedFnBody sep = case _ of
+  Guarded xs -> foldWithSeparator break $ map (guardedFnBody sep) xs
+  Standard x -> sep <+> fnBody x
+
+guardedFnBody :: forall a. Doc a -> GuardedFnBody -> Doc a
+guardedFnBody sep = case _ of
+  GuardedFnBody x y -> guard x </> (sep <+> fnBody y)
+
+guard :: forall a. Guard -> Doc a
+guard x = text "?" <+> case x of
+  Guard xs -> foldWithSeparator break $ map patternGuard xs
+  Otherwise -> text "otherwise"
+
+patternGuard :: forall a. PatternGuard -> Doc a
+patternGuard = case _ of
+  PatternGuard x y -> pattern' x <+> text "<-" <+> fnBody y
+  SimpleGuard x -> fnBody x

src/Printer/ModuleDef.purs

@@ -0,0 +1,25 @@
+module App.Printer.ModuleDef where
+
+import FatPrelude hiding (guard)
+
+import App.Printer.Common (surroundDoc)
+import App.Printer.FnDef (fnDef, opDef)
+import App.SyntaxTree.ModuleDef (ModuleDef(..), ModuleImport(..))
+import Dodo (Doc, break, foldWithSeparator, text, (<%>), (<+>))
+
+moduleDef :: forall a. ModuleDef -> Doc a
+moduleDef = case _ of
+  ModuleDef x y z t -> text "module"
+    <+> text (show x)
+    <%> statements "import" moduleImport break y
+    <%> statements "op" opDef break z
+    <%> statements "def" fnDef break t
+
+moduleImport :: forall a. ModuleImport -> Doc a
+moduleImport = case _ of
+  ModuleImport x y -> text (show x)
+    <+> fold ((text "as" <+> _) <<< text <<< show <$> y)
+
+statements :: forall a b. String -> (a -> Doc b) -> Doc b -> Array a -> Doc b
+statements term fn sep =
+  surroundDoc break <<< foldWithSeparator sep <<< map ((text term <+> _) <<< fn)

src/Printer/Pattern.purs

@@ -0,0 +1,16 @@
+module App.Printer.Pattern where
+
+import FatPrelude
+
+import App.Printer.Common (cellValue, var)
+import App.SyntaxTree.Pattern (Pattern(..))
+import Dodo (Doc, text, words, (<+>))
+
+pattern' :: forall a. Pattern -> Doc a
+pattern' = case _ of
+  VarPattern x -> var x
+  LitPattern x -> cellValue x
+  AliasedPattern x y -> var x <+> text "@" <+> pattern' y
+  ArrayPattern x -> words $ map pattern' x
+  Wildcard -> text "_"
+  Spread -> text "..."

src/Printer/Type.purs

@@ -0,0 +1,27 @@
+module App.Printer.Type where
+
+import FatPrelude
+import Prim hiding (Type)
+
+import App.SyntaxTree.Type (Type(..), TypeParam, TypeVar)
+import Dodo (Doc, enclose, encloseWithSeparator, foldWithSeparator, text, (<+>))
+
+type' :: forall a. Type -> Doc a
+type' = case _ of
+  TypeApply x ys -> type' x <+> encloseTypeArgs (type' <$> ys)
+  ArrowTypeApply xs -> foldWithSeparator (text "->") (type' <$> xs)
+  ArrayTypeApply x -> encloseType $ type' x
+  TypeVar' x -> typeVar x
+  TypeParam' x -> typeParam x
+
+typeParam :: forall a. TypeParam -> Doc a
+typeParam = text <<< show
+
+typeVar :: forall a. TypeVar -> Doc a
+typeVar = text <<< show
+
+encloseTypeArgs :: forall f a. Foldable f => f (Doc a) -> Doc a
+encloseTypeArgs = encloseWithSeparator (text "[") (text "]") (text ",")
+
+encloseType :: forall a. Doc a -> Doc a
+encloseType = enclose (text "[") (text "]")

src/SyntaxTree/FnDef.purs

@@ -233,6 +233,11 @@ instance Hashable Scope where
 derive instance Eq Associativity
 derive instance Generic Associativity _
 
+instance Show Associativity where
+  show = case _ of
+    L -> "L"
+    R -> "R"
+
 instance EncodeJson Associativity where
   encodeJson = genericEncodeJson
 
@@ -243,6 +248,9 @@ derive instance Eq Precedence
 derive instance Ord Precedence
 derive instance Generic Precedence _
 
+instance Show Precedence where
+  show = show <<< fromEnum
+
 instance Enum Precedence where
   succ = genericSucc
   pred = genericPred

src/SyntaxTree/Type.purs

@@ -14,7 +14,6 @@ newtype TypeVar = TypeVar String
 data Type
   = TypeApply Type (Array Type)
   | ArrowTypeApply (Array Type)
-  | UnionTypeApply (Array Type)
   | ArrayTypeApply Type
   | TypeVar' TypeVar
   | TypeParam' TypeParam

src/Utils/SyntaxAtom.purs

@@ -68,7 +68,6 @@ typeToSyntaxAtoms :: Type -> Array SyntaxAtom
 typeToSyntaxAtoms = case _ of
   TypeApply x ys -> typeApply x ys
   ArrowTypeApply xs -> infixTypeApply "➾" xs
-  UnionTypeApply xs -> infixTypeApply "|" xs
   ArrayTypeApply x -> wrapSquare $ typeToSyntaxAtoms x
   TypeVar' x -> [ var x ]
   TypeParam' x -> [ var x ]