purescript-0.15.15: tests/TestCoreFn.hs
{-# LANGUAGE DoAndIfThenElse #-}
module TestCoreFn (spec) where
import Prelude
import Data.Aeson (Result(..), Value)
import Data.Aeson.Types (parse)
import Data.Map as M
import Data.Version (Version(..))
import Language.PureScript.AST.Literals (Literal(..))
import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..))
import Language.PureScript.Comments (Comment(..))
import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..), ssAnn)
import Language.PureScript.CoreFn.FromJSON (moduleFromJSON)
import Language.PureScript.CoreFn.ToJSON (moduleToJSON)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..))
import Language.PureScript.PSString (mkString)
import Test.Hspec (Spec, context, shouldBe, shouldSatisfy, specify)
parseModule :: Value -> Result (Version, Module Ann)
parseModule = parse moduleFromJSON
-- convert a module to its json CoreFn representation and back
parseMod :: Module Ann -> Result (Module Ann)
parseMod m =
let v = Version [0] []
in snd <$> parseModule (moduleToJSON v m)
isSuccess :: Result a -> Bool
isSuccess (Success _) = True
isSuccess _ = False
spec :: Spec
spec = context "CoreFnFromJson" $ do
let mn = ModuleName "Example.Main"
mp = "src/Example/Main.purs"
ss = SourceSpan mp (SourcePos 0 0) (SourcePos 0 0)
ann = ssAnn ss
specify "should parse version" $ do
let v = Version [0, 13, 6] []
m = Module ss [] mn mp [] [] M.empty [] []
r = fst <$> parseModule (moduleToJSON v m)
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success v' -> v' `shouldBe` v
specify "should parse an empty module" $ do
let r = parseMod $ Module ss [] mn mp [] [] M.empty [] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> moduleName m `shouldBe` mn
specify "should parse source span" $ do
let r = parseMod $ Module ss [] mn mp [] [] M.empty [] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> moduleSourceSpan m `shouldBe` ss
specify "should parse module path" $ do
let r = parseMod $ Module ss [] mn mp [] [] M.empty [] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> modulePath m `shouldBe` mp
specify "should parse imports" $ do
let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] M.empty [] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> moduleImports m `shouldBe` [(ann, mn)]
specify "should parse exports" $ do
let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] M.empty [] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> moduleExports m `shouldBe` [Ident "exp"]
specify "should parse re-exports" $ do
let r = parseMod $ Module ss [] mn mp [] [] (M.singleton (ModuleName "Example.A") [Ident "exp"]) [] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> moduleReExports m `shouldBe` M.singleton (ModuleName "Example.A") [Ident "exp"]
specify "should parse foreign" $ do
let r = parseMod $ Module ss [] mn mp [] [] M.empty [Ident "exp"] []
r `shouldSatisfy` isSuccess
case r of
Error _ -> return ()
Success m -> moduleForeign m `shouldBe` [Ident "exp"]
context "Expr" $ do
specify "should parse literals" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "x1") $ Literal ann (NumericLiteral (Left 1))
, NonRec ann (Ident "x2") $ Literal ann (NumericLiteral (Right 1.0))
, NonRec ann (Ident "x3") $ Literal ann (StringLiteral (mkString "abc"))
, NonRec ann (Ident "x4") $ Literal ann (CharLiteral 'c')
, NonRec ann (Ident "x5") $ Literal ann (BooleanLiteral True)
, NonRec ann (Ident "x6") $ Literal ann (ArrayLiteral [Literal ann (CharLiteral 'a')])
, NonRec ann (Ident "x7") $ Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 'a'))])
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse Constructor" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "constructor") $ Constructor ann (ProperName "Either") (ProperName "Left") [Ident "value0"] ]
parseMod m `shouldSatisfy` isSuccess
specify "should parse Accessor" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "x") $
Accessor ann (mkString "field") (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (NumericLiteral (Left 1)))]) ]
parseMod m `shouldSatisfy` isSuccess
specify "should parse ObjectUpdate" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "objectUpdate") $
ObjectUpdate ann
(Literal ann $ ObjectLiteral [(mkString "field", Literal ann (StringLiteral (mkString "abc")))])
(Just [mkString "unchangedField"])
[(mkString "field", Literal ann (StringLiteral (mkString "xyz")))]
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse Abs" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "abs")
$ Abs ann (Ident "x") (Var ann (Qualified (ByModuleName mn) (Ident "x")))
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse App" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "app")
$ App ann
(Abs ann (Ident "x") (Var ann (Qualified ByNullSourcePos (Ident "x"))))
(Literal ann (CharLiteral 'c'))
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse UnusedIdent in Abs" $ do
let i = NonRec ann (Ident "f") (Abs ann UnusedIdent (Var ann (Qualified ByNullSourcePos (Ident "x"))))
let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [i]
r `shouldSatisfy` isSuccess
case r of
Error _ -> pure ()
Success Module{..} ->
moduleDecls `shouldBe` [i]
specify "should parse Case" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "case") $
Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))]
[ CaseAlternative
[ NullBinder ann ]
(Right (Literal ann (CharLiteral 'a')))
]
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse Case with guards" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "case") $
Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))]
[ CaseAlternative
[ NullBinder ann ]
(Left [(Literal ann (BooleanLiteral True), Literal ann (CharLiteral 'a'))])
]
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse Let" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "case") $
Let ann
[ Rec [((ann, Ident "a"), Var ann (Qualified ByNullSourcePos (Ident "x")))] ]
(Literal ann (BooleanLiteral True))
]
parseMod m `shouldSatisfy` isSuccess
context "Meta" $ do
specify "should parse IsConstructor" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec (ss, [], Just (IsConstructor ProductType [Ident "x"])) (Ident "x") $
Literal (ss, [], Just (IsConstructor SumType [])) (CharLiteral 'a')
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse IsNewtype" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec (ss, [], Just IsNewtype) (Ident "x") $
Literal ann (CharLiteral 'a')
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse IsTypeClassConstructor" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec (ss, [], Just IsTypeClassConstructor) (Ident "x") $
Literal ann (CharLiteral 'a')
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse IsForeign" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec (ss, [], Just IsForeign) (Ident "x") $
Literal ann (CharLiteral 'a')
]
parseMod m `shouldSatisfy` isSuccess
context "Binders" $ do
specify "should parse LiteralBinder" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "case") $
Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))]
[ CaseAlternative
[ LiteralBinder ann (BooleanLiteral True) ]
(Right (Literal ann (CharLiteral 'a')))
]
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse VarBinder" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "case") $
Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))]
[ CaseAlternative
[ ConstructorBinder
ann
(Qualified (ByModuleName (ModuleName "Data.Either")) (ProperName "Either"))
(Qualified ByNullSourcePos (ProperName "Left"))
[VarBinder ann (Ident "z")]
]
(Right (Literal ann (CharLiteral 'a')))
]
]
parseMod m `shouldSatisfy` isSuccess
specify "should parse NamedBinder" $ do
let m = Module ss [] mn mp [] [] M.empty []
[ NonRec ann (Ident "case") $
Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))]
[ CaseAlternative
[ NamedBinder ann (Ident "w") (NamedBinder ann (Ident "w'") (VarBinder ann (Ident "w''"))) ]
(Right (Literal ann (CharLiteral 'a')))
]
]
parseMod m `shouldSatisfy` isSuccess
context "Comments" $ do
specify "should parse LineComment" $ do
let m = Module ss [ LineComment "line" ] mn mp [] [] M.empty [] []
parseMod m `shouldSatisfy` isSuccess
specify "should parse BlockComment" $ do
let m = Module ss [ BlockComment "block" ] mn mp [] [] M.empty [] []
parseMod m `shouldSatisfy` isSuccess