packages feed

purescript 0.5.7.1 → 0.6.0

raw patch · 30 files changed

+595/−1374 lines, 30 filesdep +file-embeddep −unixdep ~basenew-component:exe:psc-docs

Dependencies added: file-embed

Dependencies removed: unix

Dependency ranges changed: base

Files

LICENSE view
@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2013 Phil Freeman+Copyright (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in
− docgen/Main.hs 
@@ -1,238 +0,0 @@----------------------------------------------------------------------------------- Module      :  Main--- Copyright   :  (c) Phil Freeman 2013--- License     :  MIT------ Maintainer  :  Phil Freeman <paf31@cantab.net>--- Stability   :  experimental--- Portability :------ |-----------------------------------------------------------------------------------module Main where--import Control.Applicative-import Control.Monad-import Control.Monad.Writer-import Data.Function (on)-import Data.List-import Data.Version (showVersion)-import qualified Language.PureScript as P-import qualified Paths_purescript as Paths-import qualified System.IO.UTF8 as U-import System.Console.CmdTheLine-import System.Exit (exitSuccess, exitFailure)-import System.IO (stderr)--docgen :: Bool -> [FilePath] -> IO ()-docgen showHierarchy input = do-  ms <- mapM parseFile (nub input)-  U.putStrLn . runDocs $ (renderModules showHierarchy) (concat ms)-  exitSuccess--parseFile :: FilePath -> IO [P.Module]-parseFile input = do-  text <- U.readFile input-  case P.runIndentParser input P.parseModules text of-    Left err -> do-      U.hPutStr stderr $ show err-      exitFailure-    Right ms -> do-      return ms--type Docs = Writer [String] ()--runDocs :: Docs -> String-runDocs = unlines . execWriter--spacer :: Docs-spacer = tell [""]--headerLevel :: Int -> String -> Docs-headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]--atIndent :: Int -> String -> Docs-atIndent indent text =-  let ls = lines text in-  forM_ ls $ \l -> tell [replicate indent ' ' ++ l]--renderModules :: Bool -> [P.Module] -> Docs-renderModules showHierarchy ms = do-  headerLevel 1 "Module Documentation"-  spacer-  mapM_ (renderModule showHierarchy) ms--renderModule :: Bool -> P.Module -> Docs-renderModule showHierarchy (P.Module moduleName ds exps) =-  let exported = filter (isExported exps) ds-      hasTypes = any isTypeDeclaration ds-      hasTypeclasses = any isTypeClassDeclaration ds-      hasTypeclassInstances = any isTypeInstanceDeclaration ds-      hasValues = any isValueDeclaration ds-  in do-    headerLevel 2 $ "Module " ++ P.runModuleName moduleName-    spacer-    when hasTypes $ do-      headerLevel 3 "Types"-      spacer-      renderTopLevel exps (filter isTypeDeclaration exported)-      spacer-    when hasTypeclasses $ do-      headerLevel 3 "Type Classes"-      spacer-      when showHierarchy $ do-        renderTypeclassImage moduleName-        spacer-      renderTopLevel exps (filter isTypeClassDeclaration exported)-      spacer-    when hasTypeclassInstances $ do-      headerLevel 3 "Type Class Instances"-      spacer-      renderTopLevel exps (filter isTypeInstanceDeclaration ds)-      spacer-    when hasValues $ do-      headerLevel 3 "Values"-      spacer-      renderTopLevel exps (filter isValueDeclaration exported)-      spacer--isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool-isExported Nothing _ = True-isExported _ P.TypeInstanceDeclaration{} = True-isExported exps (P.PositionedDeclaration _ d) = isExported exps d-isExported (Just exps) decl = any (matches decl) exps-  where-  matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'-  matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'-  matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'-  matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'-  matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'-  matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'-  matches (P.PositionedDeclaration _ d) r = d `matches` r-  matches d (P.PositionedDeclarationRef _ r) = d `matches` r-  matches _ _ = False--isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool-isDctorExported _ Nothing _ = True-isDctorExported ident (Just exps) ctor = test `any` exps-  where-  test (P.PositionedDeclarationRef _ d) = test d-  test (P.TypeRef ident' Nothing) = ident == ident'-  test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors-  test _ = False--renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs-renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do-  renderDeclaration 4 exps decl-  spacer--renderTypeclassImage :: P.ModuleName -> Docs-renderTypeclassImage name =-  let name' = P.runModuleName name-  in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]--renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs-renderDeclaration n _ (P.TypeDeclaration ident ty) =-  atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty-renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =-  atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty-renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do-  let-    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)-    typeName = prettyPrintType' typeApp-    exported = filter (isDctorExported name exps . fst) ctors-  atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")-  forM_ exported $ \(ctor, tys) ->-    let ctorTy = foldr P.function typeApp tys-    in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy-renderDeclaration n _ (P.ExternDataDeclaration name kind) =-  atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind-renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do-  let-    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)-    typeName = prettyPrintType' typeApp    -  atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty-renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do-  let impliesText = case implies of-                      [] -> ""-                      is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "-      classApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)-      className = prettyPrintType' classApp-  atIndent n $ "class " ++ impliesText ++ className ++ " where"-  mapM_ (renderDeclaration (n + 2) exps) ds-renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do-  let constraintsText = case constraints of-                          [] -> ""-                          cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "-  atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)-renderDeclaration n exps (P.PositionedDeclaration _ d) =-  renderDeclaration n exps d-renderDeclaration _ _ _ = return ()--toTypeVar :: (String, Maybe P.Kind) -> P.Type-toTypeVar (s, Nothing) = P.TypeVar s-toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k--prettyPrintType' :: P.Type -> String-prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim-  where-  dePrim ty@(P.TypeConstructor (P.Qualified _ name))-    | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =-      P.TypeConstructor $ P.Qualified Nothing name-  dePrim other = other--getName :: P.Declaration -> String-getName (P.TypeDeclaration ident _) = show ident-getName (P.ExternDeclaration _ ident _ _) = show ident-getName (P.DataDeclaration _ name _ _) = P.runProperName name-getName (P.ExternDataDeclaration name _) = P.runProperName name-getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name-getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name-getName (P.TypeInstanceDeclaration name _ _ _ _) = show name-getName (P.PositionedDeclaration _ d) = getName d-getName _ = error "Invalid argument to getName"--isValueDeclaration :: P.Declaration -> Bool-isValueDeclaration P.TypeDeclaration{} = True-isValueDeclaration P.ExternDeclaration{} = True-isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d-isValueDeclaration _ = False--isTypeDeclaration :: P.Declaration -> Bool-isTypeDeclaration P.DataDeclaration{} = True-isTypeDeclaration P.ExternDataDeclaration{} = True-isTypeDeclaration P.TypeSynonymDeclaration{} = True-isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d-isTypeDeclaration _ = False--isTypeClassDeclaration :: P.Declaration -> Bool-isTypeClassDeclaration P.TypeClassDeclaration{} = True-isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d-isTypeClassDeclaration _ = False--isTypeInstanceDeclaration :: P.Declaration -> Bool-isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True-isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d-isTypeInstanceDeclaration _ = False--inputFiles :: Term [FilePath]-inputFiles = value $ posAny [] $ posInfo { posName = "file(s)", posDoc = "The input .purs file(s)" }--includeHeirarcy :: Term Bool-includeHeirarcy = value $ flag $ (optInfo [ "h", "hierarchy-images" ]) { optDoc = "Include markdown for type class hierarchy images in the output." }--term :: Term (IO ())-term = docgen <$> includeHeirarcy <*> inputFiles--termInfo :: TermInfo-termInfo = defTI-  { termName = "docgen"-  , version  = showVersion Paths.version-  , termDoc  = "Generate Markdown documentation from PureScript extern files"-  }--main :: IO ()-main = run (term, termInfo)
+ examples/failing/MultipleErrors2.purs view
@@ -0,0 +1,5 @@+module MultipleErrors2 where++foo = itDoesntExist++bar = neitherDoesThis
+ examples/passing/MutRec2.purs view
@@ -0,0 +1,17 @@+module Main where++data A = A B+ +data B = B A++foreign import data S :: *++f :: A -> S+f a = case a of A b -> g b++g b = case b of B a -> f a++showN :: A -> S+showN a = f a++main = Debug.Trace.trace "Done"
+ examples/passing/MutRec3.purs view
@@ -0,0 +1,17 @@+module Main where++data A = A B+ +data B = B A++foreign import data S :: *++f a = case a of A b -> g b++g :: B -> S+g b = case b of B a -> f a++showN :: A -> S+showN a = f a++main = Debug.Trace.trace "Done"
+ examples/passing/ObjectUpdate2.purs view
@@ -0,0 +1,14 @@+module Main where++type X r = { | r }++foreign import x "var x = {};" :: forall r. X r++blah :: forall r. X r -> X r+blah x = x++test = blah x +  { baz = "blah"+  }++main = Debug.Trace.trace "Done"
+ examples/passing/TypeClassImport.purs view
@@ -0,0 +1,18 @@+module Main where++foreign import data T :: *++foreign import data C :: *++foreign import t "var t = null;" :: T++foreign import inst """+  var inst = { +    show: function(t) { +      return 'Done'; +    }+  }""" :: C++foreign import instance inst :: Show T++main = Debug.Trace.print t
− prelude/prelude.purs 
@@ -1,944 +0,0 @@-module Prelude-  ( flip-  , const-  , asTypeOf-  , Semigroupoid, (<<<), (>>>)-  , Category, id-  , ($), (#)-  , (:), cons-  , Show, show-  , Functor, (<$>), void-  , Apply, (<*>)-  , Applicative, pure, liftA1-  , Bind, (>>=)-  , Monad, return, liftM1, ap-  , Num, (+), (-), (*), (/), (%)-  , negate-  , Eq, (==), (/=), refEq, refIneq-  , Ord, Ordering(..), compare, (<), (>), (<=), (>=)-  , Bits, (&), (|), (^), shl, shr, zshr, complement-  , BoolLike, (&&), (||)-  , not-  , Semigroup, (<>), (++)-  , Unit(..), unit-  ) where--  flip :: forall a b c. (a -> b -> c) -> b -> a -> c-  flip f b a = f a b--  const :: forall a b. a -> b -> a-  const a _ = a--  asTypeOf :: forall a. a -> a -> a-  asTypeOf x _ = x--  infixr 9 >>>-  infixr 9 <<<--  class Semigroupoid a where-    (<<<) :: forall b c d. a c d -> a b c -> a b d--  instance semigroupoidArr :: Semigroupoid (->) where-    (<<<) f g x = f (g x)--  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d-  (>>>) f g = g <<< f--  class (Semigroupoid a) <= Category a where-    id :: forall t. a t t--  instance categoryArr :: Category (->) where-    id x = x--  infixr 0 $-  infixl 0 #--  ($) :: forall a b. (a -> b) -> a -> b-  ($) f x = f x--  (#) :: forall a b. a -> (a -> b) -> b-  (#) x f = f x--  infixr 6 :--  (:) :: forall a. a -> [a] -> [a]-  (:) = cons--  foreign import cons-    "function cons(e) {\-    \  return function(l) {\-    \    return [e].concat(l);\-    \  };\-    \}" :: forall a. a -> [a] -> [a]--  class Show a where-    show :: a -> String--  foreign import showStringImpl-    "function showStringImpl(s) {\-    \  return JSON.stringify(s);\-    \}" :: String -> String--  instance showUnit :: Show Unit where-    show (Unit {}) = "Unit {}"--  instance showString :: Show String where-    show = showStringImpl--  instance showBoolean :: Show Boolean where-    show true = "true"-    show false = "false"--  foreign import showNumberImpl "function showNumberImpl(n) {\-                                \  return n.toString();\-                                \}" :: Number -> String--  instance showNumber :: Show Number where-    show = showNumberImpl--  foreign import showArrayImpl-    "function showArrayImpl(f) {\-    \  return function(xs) {\-    \    var ss = [];\-    \    for (var i = 0, l = xs.length; i < l; i++) {\-    \      ss[i] = f(xs[i]);\-    \    }\-    \    return '[' + ss.join(',') + ']';\-    \  };\-    \}" :: forall a. (a -> String) -> [a] -> String--  instance showArray :: (Show a) => Show [a] where-    show = showArrayImpl show--  infixl 4 <$>--  class Functor f where-    (<$>) :: forall a b. (a -> b) -> f a -> f b--  void :: forall f a. (Functor f) => f a -> f Unit-  void fa = const unit <$> fa--  infixl 4 <*>--  class (Functor f) <= Apply f where-    (<*>) :: forall a b. f (a -> b) -> f a -> f b--  class (Apply f) <= Applicative f where-    pure :: forall a. a -> f a--  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b-  liftA1 f a = pure f <*> a--  infixl 1 >>=--  class (Apply m) <= Bind m where-    (>>=) :: forall a b. m a -> (a -> m b) -> m b--  class (Applicative m, Bind m) <= Monad m--  return :: forall m a. (Monad m) => a -> m a-  return = pure--  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b-  liftM1 f a = do-    a' <- a-    return (f a')--  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b-  ap f a = do-    f' <- f-    a' <- a-    return (f' a')--  instance functorArr :: Functor ((->) r) where-    (<$>) = (<<<)--  instance applyArr :: Apply ((->) r) where-    (<*>) f g x = f x (g x)--  instance applicativeArr :: Applicative ((->) r) where-    pure = const--  instance bindArr :: Bind ((->) r) where-    (>>=) m f x = f (m x) x--  instance monadArr :: Monad ((->) r)--  infixl 7 *-  infixl 7 /-  infixl 7 %--  infixl 6 --  infixl 6 +--  class Num a where-    (+) :: a -> a -> a-    (-) :: a -> a -> a-    (*) :: a -> a -> a-    (/) :: a -> a -> a-    (%) :: a -> a -> a-    negate :: a -> a--  foreign import numAdd "function numAdd(n1) {\-                        \  return function(n2) {\-                        \    return n1 + n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numSub "function numSub(n1) {\-                        \  return function(n2) {\-                        \    return n1 - n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numMul "function numMul(n1) {\-                        \  return function(n2) {\-                        \    return n1 * n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numDiv "function numDiv(n1) {\-                        \  return function(n2) {\-                        \    return n1 / n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numMod "function numMod(n1) {\-                        \  return function(n2) {\-                        \    return n1 % n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numNegate "function numNegate(n) {\-                           \  return -n;\-                           \}" :: Number -> Number--  instance numNumber :: Num Number where-    (+) = numAdd-    (-) = numSub-    (*) = numMul-    (/) = numDiv-    (%) = numMod-    negate = numNegate--  newtype Unit = Unit {}--  unit :: Unit-  unit = Unit {}--  infix 4 ==-  infix 4 /=--  class Eq a where-    (==) :: a -> a -> Boolean-    (/=) :: a -> a -> Boolean--  foreign import refEq-    "function refEq(r1) {\-    \  return function(r2) {\-    \    return r1 === r2;\-    \  };\-    \}" :: forall a. a -> a -> Boolean--  foreign import refIneq-    "function refIneq(r1) {\-    \  return function(r2) {\-    \    return r1 !== r2;\-    \  };\-    \}" :: forall a. a -> a -> Boolean--  instance eqUnit :: Eq Unit where-    (==) (Unit {}) (Unit {}) = true-    (/=) (Unit {}) (Unit {}) = false--  instance eqString :: Eq String where-    (==) = refEq-    (/=) = refIneq--  instance eqNumber :: Eq Number where-    (==) = refEq-    (/=) = refIneq--  instance eqBoolean :: Eq Boolean where-    (==) = refEq-    (/=) = refIneq--  foreign import eqArrayImpl-    "function eqArrayImpl(f) {\-    \  return function(xs) {\-    \    return function(ys) {\-    \      if (xs.length !== ys.length) return false;\-    \      for (var i = 0; i < xs.length; i++) {\-    \        if (!f(xs[i])(ys[i])) return false;\-    \      }\-    \      return true;\-    \    };\-    \  };\-    \}" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean--  instance eqArray :: (Eq a) => Eq [a] where-    (==) xs ys = eqArrayImpl (==) xs ys-    (/=) xs ys = not (xs == ys)--  data Ordering = LT | GT | EQ--  instance eqOrdering :: Eq Ordering where-    (==) LT LT = true-    (==) GT GT = true-    (==) EQ EQ = true-    (==) _  _  = false-    (/=) x y = not (x == y)--  instance showOrdering :: Show Ordering where-    show LT = "LT"-    show GT = "GT"-    show EQ = "EQ"--  class (Eq a) <= Ord a where-    compare :: a -> a -> Ordering--  infixl 4 <--  (<) :: forall a. (Ord a) => a -> a -> Boolean-  (<) a1 a2 = case a1 `compare` a2 of-    LT -> true-    _ -> false--  infixl 4 >--  (>) :: forall a. (Ord a) => a -> a -> Boolean-  (>) a1 a2 = case a1 `compare` a2 of-    GT -> true-    _ -> false--  infixl 4 <=--  (<=) :: forall a. (Ord a) => a -> a -> Boolean-  (<=) a1 a2 = case a1 `compare` a2 of-    GT -> false-    _ -> true--  infixl 4 >=--  (>=) :: forall a. (Ord a) => a -> a -> Boolean-  (>=) a1 a2 = case a1 `compare` a2 of-    LT -> false-    _ -> true--  foreign import unsafeCompareImpl-    "function unsafeCompareImpl(lt) {\-    \  return function(eq) {\-    \    return function(gt) {\-    \      return function(x) {\-    \        return function(y) {\-    \          return x < y ? lt : x > y ? gt : eq;\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering--  unsafeCompare :: forall a. a -> a -> Ordering-  unsafeCompare = unsafeCompareImpl LT EQ GT--  instance ordUnit :: Ord Unit where-    compare (Unit {}) (Unit {}) = EQ--  instance ordBoolean :: Ord Boolean where-    compare false false = EQ-    compare false true  = LT-    compare true  true  = EQ-    compare true  false = GT--  instance ordNumber :: Ord Number where-    compare = unsafeCompare--  instance ordString :: Ord String where-    compare = unsafeCompare--  instance ordArray :: (Ord a) => Ord [a] where-    compare [] [] = EQ-    compare [] _ = LT-    compare _ [] = GT-    compare (x:xs) (y:ys) = case compare x y of-      EQ -> compare xs ys-      other -> other--  infixl 10 &-  infixl 10 |-  infixl 10 ^--  class Bits b where-    (&) :: b -> b -> b-    (|) :: b -> b -> b-    (^) :: b -> b -> b-    shl :: b -> Number -> b-    shr :: b -> Number -> b-    zshr :: b -> Number -> b-    complement :: b -> b--  foreign import numShl "function numShl(n1) {\-                        \  return function(n2) {\-                        \    return n1 << n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numShr "function numShr(n1) {\-                        \  return function(n2) {\-                        \    return n1 >> n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numZshr "function numZshr(n1) {\-                          \  return function(n2) {\-                          \    return n1 >>> n2;\-                          \  };\-                          \}" :: Number -> Number -> Number--  foreign import numAnd "function numAnd(n1) {\-                        \  return function(n2) {\-                        \    return n1 & n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numOr "function numOr(n1) {\-                       \  return function(n2) {\-                       \    return n1 | n2;\-                       \  };\-                       \}" :: Number -> Number -> Number--  foreign import numXor "function numXor(n1) {\-                        \  return function(n2) {\-                        \    return n1 ^ n2;\-                        \  };\-                        \}" :: Number -> Number -> Number--  foreign import numComplement "function numComplement(n) {\-                               \  return ~n;\-                               \}" :: Number -> Number--  instance bitsNumber :: Bits Number where-    (&) = numAnd-    (|) = numOr-    (^) = numXor-    shl = numShl-    shr = numShr-    zshr = numZshr-    complement = numComplement--  infixr 2 ||-  infixr 3 &&--  class BoolLike b where-    (&&) :: b -> b -> b-    (||) :: b -> b -> b-    not :: b -> b--  foreign import boolAnd "function boolAnd(b1) {\-                         \  return function(b2) {\-                         \    return b1 && b2;\-                         \  };\-                         \}"  :: Boolean -> Boolean -> Boolean--  foreign import boolOr "function boolOr(b1) {\-                        \  return function(b2) {\-                        \    return b1 || b2;\-                        \  };\-                        \}" :: Boolean -> Boolean -> Boolean--  foreign import boolNot "function boolNot(b) {\-                         \  return !b;\-                         \}" :: Boolean -> Boolean--  instance boolLikeBoolean :: BoolLike Boolean where-    (&&) = boolAnd-    (||) = boolOr-    not = boolNot--  infixr 5 <>--  class Semigroup a where-    (<>) :: a -> a -> a--  foreign import concatString-    "function concatString(s1) {\-    \  return function(s2) {\-    \    return s1 + s2;\-    \  };\-    \}" :: String -> String -> String--  instance semigroupUnit :: Semigroup Unit where-    (<>) (Unit {}) (Unit {}) = Unit {}--  instance semigroupString :: Semigroup String where-    (<>) = concatString--  instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where-    (<>) f g = \x -> f x <> g x--  infixr 5 ++--  (++) :: forall s. (Semigroup s) => s -> s -> s-  (++) = (<>)--module Data.Function where--  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c-  on f g x y = g x `f` g y--  foreign import data Fn0 :: * -> *-  foreign import data Fn1 :: * -> * -> *-  foreign import data Fn2 :: * -> * -> * -> *-  foreign import data Fn3 :: * -> * -> * -> * -> *-  foreign import data Fn4 :: * -> * -> * -> * -> * -> *-  foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *-  foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *-  foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *-  foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *-  foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *-  foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *--  foreign import mkFn0-    "function mkFn0(fn) {\-    \  return function() {\-    \    return fn({});\-    \  };\-    \}" :: forall a. (Unit -> a) -> Fn0 a--  foreign import mkFn1-    "function mkFn1(fn) {\-    \  return function(a) {\-    \    return fn(a);\-    \  };\-    \}" :: forall a b. (a -> b) -> Fn1 a b--  foreign import mkFn2-    "function mkFn2(fn) {\-    \  return function(a, b) {\-    \    return fn(a)(b);\-    \  };\-    \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c--  foreign import mkFn3-    "function mkFn3(fn) {\-    \  return function(a, b, c) {\-    \    return fn(a)(b)(c);\-    \  };\-    \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d--  foreign import mkFn4-    "function mkFn4(fn) {\-    \  return function(a, b, c, d) {\-    \    return fn(a)(b)(c)(d);\-    \  };\-    \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e--  foreign import mkFn5-    "function mkFn5(fn) {\-    \  return function(a, b, c, d, e) {\-    \    return fn(a)(b)(c)(d)(e);\-    \  };\-    \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f--  foreign import mkFn6-    "function mkFn6(fn) {\-    \  return function(a, b, c, d, e, f) {\-    \    return fn(a)(b)(c)(d)(e)(f);\-    \  };\-    \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g--  foreign import mkFn7-    "function mkFn7(fn) {\-    \  return function(a, b, c, d, e, f, g) {\-    \    return fn(a)(b)(c)(d)(e)(f)(g);\-    \  };\-    \}" :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h--  foreign import mkFn8-    "function mkFn8(fn) {\-    \  return function(a, b, c, d, e, f, g, h) {\-    \    return fn(a)(b)(c)(d)(e)(f)(g)(h);\-    \  };\-    \}" :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i--  foreign import mkFn9-    "function mkFn9(fn) {\-    \  return function(a, b, c, d, e, f, g, h, i) {\-    \    return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\-    \  };\-    \}" :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j--  foreign import mkFn10-    "function mkFn10(fn) {\-    \  return function(a, b, c, d, e, f, g, h, i, j) {\-    \    return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\-    \  };\-    \}" :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k--  foreign import runFn0-    "function runFn0(fn) {\-    \  return fn();\-    \}" :: forall a. Fn0 a -> a--  foreign import runFn1-    "function runFn1(fn) {\-    \  return function(a) {\-    \    return fn(a);\-    \  };\-    \}" :: forall a b. Fn1 a b -> a -> b--  foreign import runFn2-    "function runFn2(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return fn(a, b);\-    \    };\-    \  };\-    \}" :: forall a b c. Fn2 a b c -> a -> b -> c--  foreign import runFn3-    "function runFn3(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return fn(a, b, c);\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d--  foreign import runFn4-    "function runFn4(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return fn(a, b, c, d);\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e--  foreign import runFn5-    "function runFn5(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return function(e) {\-    \            return fn(a, b, c, d, e);\-    \          };\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f--  foreign import runFn6-    "function runFn6(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return function(e) {\-    \            return function(f) {\-    \              return fn(a, b, c, d, e, f);\-    \            };\-    \          };\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g--  foreign import runFn7-    "function runFn7(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return function(e) {\-    \            return function(f) {\-    \              return function(g) {\-    \                return fn(a, b, c, d, e, f, g);\-    \              };\-    \            };\-    \          };\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h--  foreign import runFn8-    "function runFn8(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return function(e) {\-    \            return function(f) {\-    \              return function(g) {\-    \                return function(h) {\-    \                  return fn(a, b, c, d, e, f, g, h);\-    \                };\-    \              };\-    \            };\-    \          };\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i--  foreign import runFn9-    "function runFn9(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return function(e) {\-    \            return function(f) {\-    \              return function(g) {\-    \                return function(h) {\-    \                  return function(i) {\-    \                    return fn(a, b, c, d, e, f, g, h, i);\-    \                  };\-    \                };\-    \              };\-    \            };\-    \          };\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j--  foreign import runFn10-    "function runFn10(fn) {\-    \  return function(a) {\-    \    return function(b) {\-    \      return function(c) {\-    \        return function(d) {\-    \          return function(e) {\-    \            return function(f) {\-    \              return function(g) {\-    \                return function(h) {\-    \                  return function(i) {\-    \                    return function(j) {\-    \                      return fn(a, b, c, d, e, f, g, h, i, j);\-    \                    };\-    \                  };\-    \                };\-    \              };\-    \            };\-    \          };\-    \        };\-    \      };\-    \    };\-    \  };\-    \}" :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k--module Data.Eq where--  newtype Ref a = Ref a--  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b-  liftRef f (Ref x) (Ref y) = f x y--  instance eqRef :: Eq (Ref a) where-    (==) = liftRef refEq-    (/=) = liftRef refIneq--  instance functorRef :: Functor Ref where-    (<$>) f (Ref x) = Ref (f x)--module Prelude.Unsafe where--  foreign import unsafeIndex-    "function unsafeIndex(xs) {\-    \  return function(n) {\-    \    return xs[n];\-    \  };\-    \}" :: forall a. [a] -> Number -> a--module Control.Monad.Eff where--  foreign import data Eff :: # ! -> * -> *--  foreign import returnE "function returnE(a) {\-                         \  return function() {\-                         \    return a;\-                         \  };\-                         \}" :: forall e a. a -> Eff e a--  foreign import bindE "function bindE(a) {\-                       \  return function(f) {\-                       \    return function() {\-                       \      return f(a())();\-                       \    };\-                       \  };\-                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b--  type Pure a = forall e. Eff e a--  foreign import runPure "function runPure(f) {\-                         \  return f();\-                         \}" :: forall a. Pure a -> a--  instance functorEff :: Functor (Eff e) where-    (<$>) = liftA1--  instance applyEff :: Apply (Eff e) where-    (<*>) = ap--  instance applicativeEff :: Applicative (Eff e) where-    pure = returnE--  instance bindEff :: Bind (Eff e) where-    (>>=) = bindE--  instance monadEff :: Monad (Eff e)--  foreign import untilE "function untilE(f) {\-                        \  return function() {\-                        \    while (!f());\-                        \    return {};\-                        \  };\-                        \}" :: forall e. Eff e Boolean -> Eff e Unit--  foreign import whileE "function whileE(f) {\-                        \  return function(a) {\-                        \    return function() {\-                        \      while (f()) {\-                        \        a();\-                        \      }\-                        \      return {};\-                        \    };\-                        \  };\-                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit--  foreign import forE "function forE(lo) {\-                      \  return function(hi) {\-                      \    return function(f) {\-                      \      return function() {\-                      \        for (var i = lo; i < hi; i++) {\-                      \          f(i)();\-                      \        }\-                      \      };\-                      \    };\-                      \  };\-                      \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit---  foreign import foreachE "function foreachE(as) {\-                          \  return function(f) {\-                          \    return function() {\-                          \      for (var i = 0; i < as.length; i++) {\-                          \        f(as[i])();\-                          \      }\-                          \    };\-                          \  };\-                          \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit--module Control.Monad.Eff.Unsafe where--  import Control.Monad.Eff--  foreign import unsafeInterleaveEff-    "function unsafeInterleaveEff(f) {\-    \  return f;\-    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a--module Debug.Trace where--  import Control.Monad.Eff--  foreign import data Trace :: !--  foreign import trace "function trace(s) {\-                       \  return function() {\-                       \    console.log(s);\-                       \    return {};\-                       \  };\-                       \}" :: forall r. String -> Eff (trace :: Trace | r) Unit--  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit-  print o = trace (show o)--module Control.Monad.ST where--  import Control.Monad.Eff--  foreign import data ST :: * -> !--  foreign import data STRef :: * -> * -> *--  foreign import data STArray :: * -> * -> *--  foreign import newSTRef "function newSTRef(val) {\-                          \  return function() {\-                          \    return { value: val };\-                          \  };\-                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)--  foreign import readSTRef "function readSTRef(ref) {\-                           \  return function() {\-                           \    return ref.value;\-                           \  };\-                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a--  foreign import modifySTRef "function modifySTRef(ref) {\-                             \  return function(f) {\-                             \    return function() {\-                             \      return ref.value = f(ref.value);\-                             \    };\-                             \  };\-                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a--  foreign import writeSTRef "function writeSTRef(ref) {\-                            \  return function(a) {\-                            \    return function() {\-                            \      return ref.value = a;\-                            \    };\-                            \  };\-                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a--  foreign import newSTArray "function newSTArray(len) {\-                            \  return function(a) {\-                            \    return function() {\-                            \      var arr = [];\-                            \      for (var i = 0; i < len; i++) {\-                            \        arr[i] = a;\-                            \      };\-                            \      return arr;\-                            \    };\-                            \  };\-                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)--  foreign import peekSTArray "function peekSTArray(arr) {\-                             \  return function(i) {\-                             \    return function() {\-                             \      return arr[i];\-                             \    };\-                             \  };\-                             \}" :: forall a h r. STArray h a -> Number -> Eff (st :: ST h | r) a--  foreign import pokeSTArray "function pokeSTArray(arr) {\-                             \  return function(i) {\-                             \    return function(a) {\-                             \      return function() {\-                             \        return arr[i] = a;\-                             \      };\-                             \    };\-                             \  };\-                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a--  foreign import runST "function runST(f) {\-                       \  return f;\-                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a--  foreign import runSTArray "function runSTArray(f) {\-                            \  return f;\-                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]
+ psc-docs/Main.hs view
@@ -0,0 +1,237 @@+----------------------------------------------------------------------------+--+-- Module      :  Main+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Main where++import Control.Applicative+import Control.Monad+import Control.Monad.Writer+import Control.Arrow (first)+import Data.Function (on)+import Data.List+import Data.Version (showVersion)+import qualified Language.PureScript as P+import qualified Paths_purescript as Paths+import qualified System.IO.UTF8 as U+import System.Console.CmdTheLine+import System.Exit (exitSuccess, exitFailure)+import System.IO (stderr)++docgen :: Bool -> [FilePath] -> IO ()+docgen showHierarchy input = do+  e <- P.parseModulesFromFiles <$> mapM (fmap (first Just) . parseFile) (nub input)+  case e of+    Left err -> do+      U.hPutStr stderr $ show err+      exitFailure+    Right ms -> do+      U.putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)+      exitSuccess++parseFile :: FilePath -> IO (FilePath, String)+parseFile input = (,) input <$> U.readFile input++type Docs = Writer [String] ()++runDocs :: Docs -> String+runDocs = unlines . execWriter++spacer :: Docs+spacer = tell [""]++headerLevel :: Int -> String -> Docs+headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]++atIndent :: Int -> String -> Docs+atIndent indent text =+  let ls = lines text in+  forM_ ls $ \l -> tell [replicate indent ' ' ++ l]++renderModules :: Bool -> [P.Module] -> Docs+renderModules showHierarchy ms = do+  headerLevel 1 "Module Documentation"+  spacer+  mapM_ (renderModule showHierarchy) ms++renderModule :: Bool -> P.Module -> Docs+renderModule showHierarchy (P.Module moduleName ds exps) =+  let exported = filter (isExported exps) ds+      hasTypes = any isTypeDeclaration ds+      hasTypeclasses = any isTypeClassDeclaration ds+      hasTypeclassInstances = any isTypeInstanceDeclaration ds+      hasValues = any isValueDeclaration ds+  in do+    headerLevel 2 $ "Module " ++ P.runModuleName moduleName+    spacer+    when hasTypes $ do+      headerLevel 3 "Types"+      spacer+      renderTopLevel exps (filter isTypeDeclaration exported)+      spacer+    when hasTypeclasses $ do+      headerLevel 3 "Type Classes"+      spacer+      when showHierarchy $ do+        renderTypeclassImage moduleName+        spacer+      renderTopLevel exps (filter isTypeClassDeclaration exported)+      spacer+    when hasTypeclassInstances $ do+      headerLevel 3 "Type Class Instances"+      spacer+      renderTopLevel exps (filter isTypeInstanceDeclaration ds)+      spacer+    when hasValues $ do+      headerLevel 3 "Values"+      spacer+      renderTopLevel exps (filter isValueDeclaration exported)+      spacer++isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool+isExported Nothing _ = True+isExported _ P.TypeInstanceDeclaration{} = True+isExported exps (P.PositionedDeclaration _ d) = isExported exps d+isExported (Just exps) decl = any (matches decl) exps+  where+  matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'+  matches (P.ExternDeclaration _ ident _ _) (P.ValueRef ident') = ident == ident'+  matches (P.DataDeclaration _ ident _ _) (P.TypeRef ident' _) = ident == ident'+  matches (P.ExternDataDeclaration ident _) (P.TypeRef ident' _) = ident == ident'+  matches (P.TypeSynonymDeclaration ident _ _) (P.TypeRef ident' _) = ident == ident'+  matches (P.TypeClassDeclaration ident _ _ _) (P.TypeClassRef ident') = ident == ident'+  matches (P.PositionedDeclaration _ d) r = d `matches` r+  matches d (P.PositionedDeclarationRef _ r) = d `matches` r+  matches _ _ = False++isDctorExported :: P.ProperName -> Maybe [P.DeclarationRef] -> P.ProperName -> Bool+isDctorExported _ Nothing _ = True+isDctorExported ident (Just exps) ctor = test `any` exps+  where+  test (P.PositionedDeclarationRef _ d) = test d+  test (P.TypeRef ident' Nothing) = ident == ident'+  test (P.TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors+  test _ = False++renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs+renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do+  renderDeclaration 4 exps decl+  spacer++renderTypeclassImage :: P.ModuleName -> Docs+renderTypeclassImage name =+  let name' = P.runModuleName name+  in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]++renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs+renderDeclaration n _ (P.TypeDeclaration ident ty) =+  atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty+renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =+  atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty+renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do+  let+    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)+    typeName = prettyPrintType' typeApp+    exported = filter (isDctorExported name exps . fst) ctors+  atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")+  forM_ exported $ \(ctor, tys) ->+    let ctorTy = foldr P.function typeApp tys+    in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy+renderDeclaration n _ (P.ExternDataDeclaration name kind) =+  atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind+renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do+  let+    typeApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)+    typeName = prettyPrintType' typeApp    +  atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty+renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do+  let impliesText = case implies of+                      [] -> ""+                      is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "+      classApp  = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)+      className = prettyPrintType' classApp+  atIndent n $ "class " ++ impliesText ++ className ++ " where"+  mapM_ (renderDeclaration (n + 2) exps) ds+renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do+  let constraintsText = case constraints of+                          [] -> ""+                          cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "+  atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)+renderDeclaration n exps (P.PositionedDeclaration _ d) =+  renderDeclaration n exps d+renderDeclaration _ _ _ = return ()++toTypeVar :: (String, Maybe P.Kind) -> P.Type+toTypeVar (s, Nothing) = P.TypeVar s+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k++prettyPrintType' :: P.Type -> String+prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim+  where+  dePrim ty@(P.TypeConstructor (P.Qualified _ name))+    | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =+      P.TypeConstructor $ P.Qualified Nothing name+  dePrim other = other++getName :: P.Declaration -> String+getName (P.TypeDeclaration ident _) = show ident+getName (P.ExternDeclaration _ ident _ _) = show ident+getName (P.DataDeclaration _ name _ _) = P.runProperName name+getName (P.ExternDataDeclaration name _) = P.runProperName name+getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name+getName (P.TypeInstanceDeclaration name _ _ _ _) = show name+getName (P.PositionedDeclaration _ d) = getName d+getName _ = error "Invalid argument to getName"++isValueDeclaration :: P.Declaration -> Bool+isValueDeclaration P.TypeDeclaration{} = True+isValueDeclaration P.ExternDeclaration{} = True+isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d+isValueDeclaration _ = False++isTypeDeclaration :: P.Declaration -> Bool+isTypeDeclaration P.DataDeclaration{} = True+isTypeDeclaration P.ExternDataDeclaration{} = True+isTypeDeclaration P.TypeSynonymDeclaration{} = True+isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d+isTypeDeclaration _ = False++isTypeClassDeclaration :: P.Declaration -> Bool+isTypeClassDeclaration P.TypeClassDeclaration{} = True+isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d+isTypeClassDeclaration _ = False++isTypeInstanceDeclaration :: P.Declaration -> Bool+isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True+isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d+isTypeInstanceDeclaration _ = False++inputFiles :: Term [FilePath]+inputFiles = value $ posAny [] $ posInfo { posName = "file(s)", posDoc = "The input .purs file(s)" }++includeHeirarcy :: Term Bool+includeHeirarcy = value $ flag $ (optInfo [ "h", "hierarchy-images" ]) { optDoc = "Include markdown for type class hierarchy images in the output." }++term :: Term (IO ())+term = docgen <$> includeHeirarcy <*> inputFiles++termInfo :: TermInfo+termInfo = defTI+  { termName = "psc-docs"+  , version  = showVersion Paths.version+  , termDoc  = "Generate Markdown documentation from PureScript extern files"+  }++main :: IO ()+main = run (term, termInfo)
psc-make/Main.hs view
@@ -12,13 +12,14 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}  module Main where  import Control.Applicative import Control.Monad.Error +import Data.Bool (bool) import Data.Version (showVersion)  import System.Console.CmdTheLine@@ -28,20 +29,20 @@ import System.Exit (exitSuccess, exitFailure) import System.IO.Error (tryIOError) -import Text.Parsec (ParseError)- import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])-readInput input = fmap collect $ forM input $ \inputFile -> do-  text <- U.readFile inputFile-  return $ (inputFile, P.runIndentParser inputFile P.parseModules text)-  where-  collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]-  collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)+data InputOptions = InputOptions+  { ioNoPrelude   :: Bool+  , ioInputFiles  :: [FilePath]+  } +readInput :: InputOptions -> IO [(Maybe FilePath, String)]+readInput InputOptions{..} = do+  content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile+  return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content+ newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)  runMake :: Make a -> IO (Either String a)@@ -66,9 +67,9 @@   liftError = either throwError return   progress = makeIO . U.putStrLn -compile :: FilePath -> [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()-compile prelude input outputDir opts usePrefix = do-  modules <- readInput allInputFiles+compile :: [FilePath] -> FilePath -> P.Options P.Make -> Bool -> IO ()+compile input outputDir opts usePrefix = do+  modules <- P.parseModulesFromFiles <$> readInput (InputOptions (P.optionsNoPrelude opts) input)   case modules of     Left err -> do       U.print err@@ -86,9 +87,6 @@                then ["Generated by psc-make version " ++ showVersion Paths.version]                else [] -    allInputFiles | P.optionsNoPrelude opts = input-                  | otherwise = prelude : input- mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -127,8 +125,8 @@ noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])      { optDoc = "Do not include comment header"} -term :: FilePath -> Term (IO ())-term prelude = compile prelude <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix)+term :: Term (IO ())+term = compile <$> inputFiles <*> outputDirectory <*> options <*> (not <$> noPrefix)  termInfo :: TermInfo termInfo = defTI@@ -138,7 +136,5 @@   }  main :: IO ()-main = do-  prelude <- P.preludeFilename-  run (term prelude, termInfo)+main = run (term, termInfo)
psc/Main.hs view
@@ -12,13 +12,14 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}  module Main where  import Control.Applicative import Control.Monad.Error +import Data.Bool (bool) import Data.Version (showVersion)  import System.Console.CmdTheLine@@ -27,26 +28,25 @@ import System.Exit (exitSuccess, exitFailure) import System.IO (stderr) -import Text.Parsec (ParseError)- import qualified Language.PureScript as P import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U -readInput :: Maybe [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])-readInput Nothing = do-  text <- getContents-  return $ map ((,) undefined) <$> P.runIndentParser "" P.parseModules text-readInput (Just input) = fmap collect $ forM input $ \inputFile -> do-  text <- U.readFile inputFile-  return $ (inputFile, P.runIndentParser inputFile P.parseModules text)-  where-  collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]-  collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)+data InputOptions = InputOptions+  { ioNoPrelude   :: Bool+  , ioUseStdIn    :: Bool+  , ioInputFiles  :: [FilePath]+  } -compile :: FilePath -> P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()-compile prelude opts stdin input output externs usePrefix = do-  modules <- readInput stdInOrInputFiles+readInput :: InputOptions -> IO [(Maybe FilePath, String)]+readInput InputOptions{..}+  | ioUseStdIn = return . (Nothing ,) <$> getContents+  | otherwise = do content <- forM ioInputFiles $ \inputFile -> (Just inputFile, ) <$> U.readFile inputFile+                   return $ bool ((Nothing, P.prelude) :) id ioNoPrelude content++compile :: P.Options P.Compile -> Bool -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Bool -> IO ()+compile opts stdin input output externs usePrefix = do+  modules <- P.parseModulesFromFiles <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)   case modules of     Left err -> do       U.hPutStr stderr $ show err@@ -65,10 +65,6 @@             Nothing -> return ()           exitSuccess   where-  stdInOrInputFiles :: Maybe [FilePath]-  stdInOrInputFiles | stdin = Nothing-                    | P.optionsNoPrelude opts = Just input-                    | otherwise = Just $ prelude : input   prefix = if usePrefix               then ["Generated by psc version " ++ showVersion Paths.version]               else []@@ -137,8 +133,8 @@   where   additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules -term :: FilePath -> Term (IO ())-term prelude = compile prelude <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)+term :: Term (IO ())+term = compile <$> options <*> useStdIn <*> inputFiles <*> outputFile <*> externsFile <*> (not <$> noPrefix)  termInfo :: TermInfo termInfo = defTI@@ -148,8 +144,6 @@   }  main :: IO ()-main = do-  prelude <- P.preludeFilename-  run (term prelude, termInfo)+main = run (term, termInfo)
psci/Commands.hs view
@@ -34,6 +34,10 @@   --   | Import ModuleName   -- |+  -- Browse a module+  --+  | Browse ModuleName+  -- |   -- Load a file for use with importing   --   | LoadFile FilePath@@ -57,6 +61,10 @@   -- Find the kind of an expression   --   | KindOf Type+  -- |+  -- Show command+  --+  | Show String  -- | -- The help menu.@@ -65,9 +73,12 @@ help =   [ [":?          ", "Show this help menu"]   , [":i <module> ", "Import <module> for use in PSCI"]+  , [":b <module> ", "Browse <module>"]   , [":m <file>   ", "Load <file> for importing"]   , [":q          ", "Quit PSCi"]   , [":r          ", "Reset"]+  , [":s import   ", "Show imported modules"]+  , [":s loaded   ", "Show loaded modules"]   , [":t <expr>   ", "Show the type of <expr>"]   , [":k <type>   ", "Show the kind of <type>"]   ]
psci/Main.hs view
@@ -28,7 +28,7 @@ import Control.Monad.Error (ErrorT(..), MonadError) import Control.Monad.Error.Class (MonadError(..)) -import Data.List (intercalate, isPrefixOf, nub, sortBy)+import Data.List (intercalate, isPrefixOf, nub, sortBy, sort) import Data.Maybe (mapMaybe) import Data.Foldable (traverse_) import Data.Version (showVersion)@@ -54,6 +54,8 @@ import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U        (writeFile, putStrLn, print, readFile)+import qualified Language.PureScript.Names as N+import qualified Language.PureScript.Declarations as D  -- | -- The PSCI state.@@ -64,7 +66,7 @@ data PSCiState = PSCiState   { psciImportedFilenames   :: [FilePath]   , psciImportedModuleNames :: [P.ModuleName]-  , psciLoadedModules       :: [(FilePath, P.Module)]+  , psciLoadedModules       :: [(Maybe FilePath, P.Module)]   , psciLetBindings         :: [P.Expr -> P.Expr]   } @@ -85,7 +87,7 @@ -- | -- Updates the state to have more loaded files. ---updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState+updateModules :: [(Maybe FilePath, P.Module)] -> PSCiState -> PSCiState updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }  -- |@@ -126,6 +128,17 @@ loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename  -- |+-- Load all modules, including the Prelude+--+loadAllModules :: [FilePath] -> IO (Either ParseError [(Maybe FilePath, P.Module)])+loadAllModules files = do+  filesAndContent <- forM files $ \filename -> do +    content <- U.readFile filename+    return (Just filename, content)+  return $ P.parseModulesFromFiles $ (Nothing, P.prelude) : filesAndContent+++-- | -- Expands tilde in path. -- expandTilde :: FilePath -> IO FilePath@@ -290,7 +303,7 @@ handleDeclaration value = do   st <- PSCI $ lift get   let m = createTemporaryModule True st value-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []+  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right _ -> do@@ -303,17 +316,38 @@         Nothing                        -> PSCI $ outputStrLn "Couldn't find node.js"  -- |+-- Show actual loaded modules in psci.+--+handleShowLoadedModules :: PSCI ()+handleShowLoadedModules = do+  PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get+  psciIO $ readModules loadedModules >>= putStrLn+  return ()+  where readModules = return . unlines . sort . nub . map toModuleName+        toModuleName =  N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd++-- |+-- Show the imported modules in psci.+--+handleShowImportedModules :: PSCI ()+handleShowImportedModules = do+  PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get+  psciIO $ readModules importedModuleNames >>= putStrLn+  return ()+  where readModules = return . unlines . sort . map N.runModuleName++-- | -- Imports a module, preserving the initial state on failure. -- handleImport :: P.ModuleName -> PSCI () handleImport moduleName = do-   s <- liftM (updateImports moduleName) $ PSCI $ lift get-   let m = createTemporaryModuleForImports s-   e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules s ++ [("$PSCI.purs", m)]) []+   st <- updateImports moduleName <$> PSCI (lift get)+   let m = createTemporaryModuleForImports st+   e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []    case e of      Left err -> PSCI $ outputStrLn err      Right _  -> do-       PSCI $ lift $ put s+       PSCI $ lift $ put st        return ()  -- |@@ -323,7 +357,7 @@ handleTypeOf value = do   st <- PSCI $ lift get   let m = createTemporaryModule False st value-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []+  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right env' ->@@ -332,6 +366,40 @@         Nothing -> PSCI $ outputStrLn "Could not find type"  -- |+-- Pretty print a module's signatures+--+printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()+printModuleSignatures moduleName env =+  PSCI $ let namesEnv = P.names env+             moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv+             in case moduleNamesIdent of+                  [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."+                  _ -> ( outputStrLn+                       . unlines+                       . sort+                       . map (showType . findType namesEnv)) moduleNamesIdent+  where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))+        findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)+        showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String+        showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType+        showType _ = error "The impossible happened in printModuleSignatures."++-- |+-- Browse a module and displays its signature (if module exists).+--+handleBrowse :: P.ModuleName -> PSCI ()+handleBrowse moduleName = do+  st <- PSCI $ lift get+  let loadedModules = psciLoadedModules st+  env <- psciIO . runMake $ P.make modulesDir options loadedModules []+  case env of+    Left err -> PSCI $ outputStrLn err+    Right env' ->+      if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules+        then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."+        else printModuleSignatures moduleName env'++-- | -- Takes a value and prints its kind -- handleKindOf :: P.Type -> PSCI ()@@ -339,7 +407,7 @@   st <- PSCI $ lift get   let m = createTemporaryModuleForKind st typ       mName = P.ModuleName [P.ProperName "$PSCI"]-  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) []+  e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Nothing, m)]) []   case e of     Left err -> PSCI $ outputStrLn err     Right env' ->@@ -385,18 +453,20 @@     m <- psciIO $ loadModule absPath     case m of       Left err -> PSCI $ outputStrLn err-      Right mods -> PSCI . lift $ modify (updateModules (map ((,) absPath) mods))+      Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Just absPath)) mods))   else     PSCI . outputStrLn $ "Couldn't locate: " ++ filePath handleCommand Reset = do   files <- psciImportedFilenames <$> PSCI (lift get)-  filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . psciIO . loadModule $ file) files-  let modulesOrFirstError = fmap concat $ sequence filesAndModules+  modulesOrFirstError <- psciIO $ loadAllModules files   case modulesOrFirstError of-    Left err -> psciIO $ putStrLn err >> exitFailure+    Left err -> psciIO $ putStrLn (show err) >> exitFailure     Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules []) handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ+handleCommand (Browse moduleName) = handleBrowse moduleName+handleCommand (Show "loaded") = handleShowLoadedModules+handleCommand (Show "import") = handleShowImportedModules handleCommand _ = PSCI $ outputStrLn "Unknown command"  singleLineFlag :: Cmd.Term Bool@@ -429,15 +499,13 @@ loop :: Bool -> [FilePath] -> IO () loop singleLineMode files = do   config <- loadUserConfig-  preludeFilename <- P.preludeFilename-  filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files)-  let modulesOrFirstError = fmap concat $ sequence filesAndModules+  modulesOrFirstError <- loadAllModules files   case modulesOrFirstError of-    Left err -> putStrLn err >> exitFailure+    Left err -> putStrLn (show err) >> exitFailure     Right modules -> do       historyFilename <- getHistoryFilename-      let settings = defaultSettings {historyFile = Just historyFilename}-      flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do+      let settings = defaultSettings { historyFile = Just historyFilename }+      flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do         outputStrLn prologueMessage         traverse_ (mapM_ (runPSCI . handleCommand)) config         go
psci/Parser.hs view
@@ -42,7 +42,7 @@ -- parseCommand :: String -> Either ParseError Command parseCommand = P.runIndentParser "" $ choice-                    [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf)+                    [ P.whiteSpace *> char ':' *> (psciHelp <|> psciImport <|> psciLoadFile <|> psciQuit <|> psciReload <|> psciTypeOf <|> psciKindOf <|> psciBrowse <|> psciShowModules)                     , try psciLet                     , psciExpression                     ] <* eof@@ -70,9 +70,11 @@ -- psciLoadFile :: Parsec String P.ParseState Command psciLoadFile = LoadFile . trimEnd <$> (char 'm' *> P.whiteSpace *> manyTill anyChar eof)-  where-  trimEnd = reverse . dropWhile isSpace . reverse +-- | Trim end of input string+trimEnd :: String -> String+trimEnd = reverse . dropWhile isSpace . reverse+ -- | -- Parses 'Commands.Quit' command. --@@ -97,3 +99,14 @@ -- psciKindOf :: Parsec String P.ParseState Command psciKindOf = KindOf <$> (char 'k' *> P.whiteSpace *> P.parseType)++-- |+-- Parses 'Commands.Browse' command.+--+psciBrowse :: Parsec String P.ParseState Command+psciBrowse = Browse <$> (char 'b' *> P.whiteSpace *> P.moduleName)++-- |+-- Show Command+psciShowModules :: Parsec String P.ParseState Command+psciShowModules = Show . trimEnd <$> (char 's' *> P.whiteSpace *> manyTill anyChar eof)
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.5.7.1+version: 0.6.0 cabal-version: >=1.8 build-type: Simple  license: MIT@@ -14,8 +14,6 @@ author: Phil Freeman <paf31@cantab.net>,         Gary Burgess <gary.burgess@gmail.com>,         Hardy Jones <jones3.hardy@gmail.com>-data-files: prelude/prelude.purs-data-dir: ""  extra-source-files: examples/passing/*.purs                   , examples/failing/*.purs@@ -25,14 +23,20 @@     location: https://github.com/purescript/purescript.git  library-    build-depends: base >=4 && <5, cmdtheline == 0.2.*, containers -any, unordered-containers -any,-                   directory >= 1.2, filepath -any, mtl >= 2.1.0 && < 2.3.0, parsec -any,-                   transformers >= 0.3 && < 0.5, utf8-string -any,+    build-depends: base >=4 && <5, +                   cmdtheline == 0.2.*, +                   containers -any, +                   unordered-containers -any,+                   directory >= 1.2, +                   filepath -any, +                   mtl >= 2.1.0 && < 2.3.0, +                   parsec -any,+                   transformers >= 0.3 && < 0.5, +                   utf8-string -any,                    pattern-arrows >= 0.0.2 && < 0.1,-                   monad-unify >= 0.2.2 && < 0.3,+                   monad-unify >= 0.2.2 && < 0.3, +                   file-embed >= 0.0.7 && < 0.0.8,                    time -any-    if (!os(windows))-        build-depends: unix -any     exposed-modules: Language.PureScript                      Language.PureScript.Constants                      Language.PureScript.Options@@ -123,12 +127,12 @@                    Parser     ghc-options: -Wall -O2 -executable docgen+executable psc-docs      build-depends: base >=4 && <5, cmdtheline -any, purescript -any, utf8-string -any,                    process -any, mtl -any     main-is: Main.hs     buildable: True-    hs-source-dirs: docgen+    hs-source-dirs: psc-docs      other-modules:     ghc-options: -Wall -O2
src/Language/PureScript.hs view
@@ -13,9 +13,9 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-} -module Language.PureScript (module P, compile, compile', MonadMake(..), make, preludeFilename) where+module Language.PureScript (module P, compile, compile', MonadMake(..), make, prelude) where  import Language.PureScript.Types as P import Language.PureScript.Kinds as P@@ -36,20 +36,23 @@ import Language.PureScript.Renamer as P  import qualified Language.PureScript.Constants as C-import qualified Paths_purescript as Paths  import Data.List (sortBy, groupBy, intercalate) import Data.Time.Clock import Data.Function (on)-import Data.Maybe (listToMaybe, fromMaybe)+import Data.Maybe (fromMaybe)+import Data.FileEmbed (embedFile)+import Data.Traversable (traverse)+ import Control.Monad.Error import Control.Arrow ((&&&)) import Control.Applicative+ import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.ByteString.UTF8 as BU -import System.FilePath ((</>), pathSeparator)-import System.Directory (getHomeDirectory, doesFileExist)+import System.FilePath ((</>))  -- | -- Compile a collection of modules@@ -136,7 +139,7 @@ -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. ---make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(FilePath, Module)] -> [String] -> m Environment+make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Maybe FilePath, Module)] -> [String] -> m Environment make outputDir opts ms prefix = do   let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms) @@ -145,13 +148,13 @@   toRebuild <- foldM (\s (Module moduleName' _ _) -> do     let filePath = runModuleName moduleName' -        jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"-        externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"-        inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap+        jsFile = outputDir </> filePath </> "index.js"+        externsFile = outputDir </> filePath </> "externs.purs"+        inputFile = join $ M.lookup moduleName' filePathMap      jsTimestamp <- getTimestamp jsFile     externsTimestamp <- getTimestamp externsFile-    inputTimestamp <- getTimestamp inputFile+    inputTimestamp <- join <$> traverse getTimestamp inputFile       return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of       (Just t1, Just t2, Just t3) | t1 < min t2 t3 -> s@@ -172,8 +175,8 @@     go env' ms'   go env ((True, m@(Module moduleName' _ exps)) : ms') = do     let filePath = runModuleName moduleName'-        jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"-        externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"+        jsFile = outputDir </> filePath </> "index.js"+        externsFile = outputDir </> filePath </> "externs.purs"      lift . progress $ "Compiling " ++ runModuleName moduleName' @@ -200,7 +203,7 @@         toRebuild' = toRebuild `S.union` S.fromList deps     (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'   rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do-    let externsFile = outputDir ++ pathSeparator : runModuleName moduleName' ++ pathSeparator : "externs.purs"+    let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"     externs <- readTextFile externsFile     externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs     case externsModules of@@ -231,18 +234,5 @@ importPrelude :: Module -> Module importPrelude = addDefaultImport (ModuleName [ProperName C.prelude]) -preludeFilename :: IO FilePath-preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do-  fs <- sequence [homePrelude, cabalPrelude]-  filterM doesFileExist fs-  where-  missingPrelude :: FilePath-  missingPrelude = error "No Prelude found in user home or cabal path."--  homePrelude :: IO FilePath-  homePrelude = do-    homeDir <- getHomeDirectory-    return $ homeDir </> ".purescript" </> "prelude" </> "prelude.purs"--  cabalPrelude :: IO FilePath-  cabalPrelude = Paths.getDataFileName "prelude/prelude.purs"+prelude :: String+prelude = BU.toString $(embedFile "prelude/prelude.purs")
src/Language/PureScript/CodeGen/JS.hs view
@@ -26,8 +26,11 @@ import Data.Function (on) import Data.List (nub, (\\), delete, sortBy) +import qualified Data.Map as M+ import Control.Monad (foldM, replicateM, forM) import Control.Applicative+import Control.Arrow (second)  import Language.PureScript.Names import Language.PureScript.Declarations@@ -51,7 +54,7 @@   let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls   let isModuleEmpty = null exps   let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized-  let moduleExports = JSObjectLiteral $ concatMap exportToJs exps+  let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps   return $ case optionsAdditional opts of     MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]     CompileOptions ns _ _ | not isModuleEmpty ->@@ -154,12 +157,12 @@ -- | -- Generate key//value pairs for an object literal exporting values from a module. ---exportToJs :: DeclarationRef -> [(String, JS)]-exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors-exportToJs (ValueRef name) = [(runIdent name, var name)]-exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]-exportToJs (TypeClassRef name) = [(runProperName name, var $ Ident $ runProperName name)]-exportToJs _ = []+exportToJs :: DeclarationRef -> M.Map String Ident+exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]+exportToJs (ValueRef name)           = M.singleton (runIdent name) name+exportToJs (TypeInstanceRef name)    = M.singleton (runIdent name) name+exportToJs (TypeClassRef name)       = M.singleton (runProperName name) (Ident $ runProperName name)+exportToJs _                         = M.empty  -- | -- Generate code in the simplified Javascript intermediate representation for a variable based on a
src/Language/PureScript/Errors.hs view
@@ -16,10 +16,12 @@  module Language.PureScript.Errors where +import Data.Either (lefts, rights) import Data.List (intersperse, intercalate) import Data.Monoid  import Control.Monad.Error+import Control.Applicative ((<$>))  import Language.PureScript.Declarations import Language.PureScript.Pretty@@ -121,3 +123,18 @@ -- rethrowWithPosition :: (MonadError ErrorStack m) => SourcePos -> m a -> m a rethrowWithPosition pos = rethrow (positionError pos <>)++-- |+-- Collect errors in in parallel+--+parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]+parU xs f = forM xs (withError . f) >>= collectErrors+  where+  withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)+  withError u = catchError (Right <$> u) (return . Left)++  collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]+  collectErrors es = case lefts es of+    [err] -> throwError err+    [] -> return $ rights es+    errs -> throwError $ MultipleErrors errs
src/Language/PureScript/Parser.hs view
src/Language/PureScript/Parser/Declarations.hs view
@@ -19,6 +19,7 @@     parseDeclaration,     parseModule,     parseModules,+    parseModulesFromFiles,     parseValue,     parseGuard,     parseBinder,@@ -26,6 +27,7 @@ ) where  import Data.Maybe (isJust, fromMaybe)+import Data.Traversable (forM)  import Control.Applicative import Control.Arrow ((+++))@@ -229,6 +231,18 @@   _ <- lexeme $ P.string "where"   decls <- mark (P.many (same *> parseDeclaration))   return $ Module name decls exports++-- |+-- Parse a collection of modules +--+parseModulesFromFiles :: [(Maybe FilePath, String)] -> Either P.ParseError [(Maybe FilePath, Module)]+parseModulesFromFiles input = +  fmap collect . forM input $ \(filename, content) -> do+    ms <- runIndentParser (fromMaybe "" filename) parseModules content+    return (filename, ms)+  where+  collect :: [(k, [v])] -> [(k, v)]+  collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]  -- | -- Parse a collection of modules
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -52,14 +52,14 @@ -- createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration] createBindingGroups moduleName ds = do-  values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds+  values <- parU (filter isValueDecl ds) (createBindingGroupsForValue moduleName)   let dataDecls = filter isDataDecl ds       allProperNames = map getProperName dataDecls       dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls-  dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts+  dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup   let allIdents = map getIdent values       valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values-  bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts+  bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)   return $ filter isImportDecl ds ++            filter isExternDataDecl ds ++            filter isExternInstanceDecl ds ++
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -43,7 +43,7 @@     Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps  desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]-desugarAbs = mapM f+desugarAbs = flip parU f   where   (f, _, _) = everywhereOnValuesM return replace return @@ -57,7 +57,7 @@ -- Replace all top-level binders with case expressions. -- desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]-desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup+desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup   where     desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]     desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -33,7 +33,7 @@ -- and all @DoNotationLet@ constructors with let expressions. -- desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module-desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts+desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts  desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
src/Language/PureScript/Sugar/Names.hs view
@@ -176,7 +176,7 @@ -- renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module renameInModule imports exports (Module mn decls exps) =-  Module mn <$> mapM go decls <*> pure exps+  Module mn <$> parU decls go <*> pure exps   where   (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS 
src/Language/PureScript/Sugar/Operators.hs view
@@ -66,7 +66,7 @@ rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module rebracketModule opTable (Module mn ds exts) =   let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return-  in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts+  in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts  removeParens :: Declaration -> Declaration removeParens =
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -53,7 +53,7 @@  desugarModule :: Module -> Desugar Module desugarModule (Module name decls (Just exps)) = do-  (newExpss, declss) <- unzip <$> mapM (desugarDecl name exps) decls+  (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)   return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss) desugarModule _ = error "Exports should have been elaborated in name desugaring" 
src/Language/PureScript/TypeChecker.hs view
@@ -183,7 +183,11 @@       forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->         valueIsNotDefined moduleName name       tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals-      vals' <- forM (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do+      vals' <- forM [ (name, val, nameKind, ty) +                    | (name, nameKind, _) <- vals+                    , (name', (val, ty)) <- tys+                    , name == name' +                    ] $ \(name, val, nameKind, ty) -> do         addValue moduleName name ty nameKind         return (name, nameKind, val)       return $ BindingGroupDeclaration vals'
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -28,7 +28,6 @@ import Language.PureScript.Errors  import Data.Maybe-import Data.Either (lefts, rights)  import Control.Applicative import Control.Monad.State@@ -233,19 +232,3 @@   (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify   modify $ \st' -> st' { checkNextVar = unifyNextVar ust }   return (a, unifyCurrentSubstitution ust)---- |--- Typecheck in parallel----parU :: [a] -> (a -> UnifyT t Check b) -> UnifyT t Check [b]-parU xs f = forM xs (withError . f) >>= collectErrors-  where-  withError :: UnifyT t Check a -> UnifyT t Check (Either ErrorStack a)-  withError u = catchError (Right <$> u) (return . Left)--  collectErrors :: [Either ErrorStack a] -> UnifyT t Check [a]-  collectErrors es = case lefts es of-    [err] -> throwError err-    [] -> return $ rights es-    errs -> throwError $ MultipleErrors errs-
src/Language/PureScript/TypeChecker/Types.hs view
@@ -192,10 +192,10 @@     skolemEscapeCheck val'     -- Check rows do not contain duplicate labels     checkDuplicateLabels val'-    -- Remove type synonyms placeholders, remove duplicate row fields, and replace+    -- Remove type synonyms placeholders, and replace     -- top-level unification variables with named type variables.-    let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'-        ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty+    let val'' = overTypes desaturateAllTypeSynonyms val'+        ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty     return (ident, (val'', ty'))   where   -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values@@ -527,42 +527,34 @@   def = return       go :: Expr -> Check Expr-  go e@(TypedValue _ _ ty) = checkDups ty >> return e-  go other = return other+  go e@(TypedValue _ val ty) = do+    checkDups ty+    return e+    +    where+    checkDups :: Type -> Check ()+    checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2+    checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts+    checkDups (ForAll _ t _) = checkDups t+    checkDups (ConstrainedType args t) = do+      mapM_ (checkDups) $ concatMap snd args+      checkDups t +    checkDups r@(RCons _ _ _) = +      let (ls, _) = rowToList r in +      case firstDup . sort . map fst $ ls of+        Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)+        Nothing -> return ()+    checkDups _ = return ()   -  checkDups :: Type -> Check ()-  checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2-  checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts-  checkDups (ForAll _ t _) = checkDups t-  checkDups (ConstrainedType args t) = do-    mapM_ (checkDups) $ concatMap snd args-    checkDups t -  checkDups r@(RCons _ _ _) = -    let (ls, _) = rowToList r in -    case firstDup . sort . map fst $ ls of-      Just l -> throwError . strMsg $ "Duplicate label " ++ show l ++ " in row"-      Nothing -> return ()-  checkDups _ = return ()+    firstDup :: (Eq a) => [a] -> Maybe a+    firstDup (x : xs@(x' : _)) +      | x == x' = Just x+      | otherwise = firstDup xs+    firstDup _ = Nothing    +        +  go other = return other   -  firstDup :: (Eq a) => [a] -> Maybe a-  firstDup (x : xs@(x' : _)) -    | x == x' = Just x-    | otherwise = firstDup xs-  firstDup _ = Nothing- -- |--- Ensure a row contains no duplicate labels----setify :: Type -> Type-setify = rowFromList . first (M.toList . M.fromList) . rowToList---- |--- \"Setify\" all rows occuring inside a value----setifyAll :: Type -> Type-setifyAll = everywhereOnTypes setify---- | -- Replace outermost unsolved unification variables with named type variables -- varIfUnknown :: Type -> Type@@ -1018,10 +1010,11 @@   return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do   ensureNoDuplicateProperties ps-  us <- zip (map fst ps) <$> replicateM (length ps) fresh+  -- We need to be careful to avoid duplicate labels here.+  -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.   let (propsToCheck, rest) = rowToList row-      propsToRemove = map fst ps-      remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck+      (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck+  us <- zip (map fst removedProps) <$> replicateM (length ps) fresh   obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))   ps' <- checkProperties ps row True   return $ TypedValue True (ObjectUpdate obj' ps') t
tests/Main.hs view
@@ -22,6 +22,7 @@ import Data.Traversable (traverse) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Applicative import System.Exit import System.Process import System.FilePath (pathSeparator)@@ -29,18 +30,24 @@ import Text.Parsec (ParseError) import qualified System.IO.UTF8 as U -readInput :: [FilePath] -> IO (Either ParseError [P.Module])-readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do+readInput :: [FilePath] -> IO [(Maybe FilePath, String)]+readInput inputFiles = forM inputFiles $ \inputFile -> do   text <- U.readFile inputFile-  return $ P.runIndentParser inputFile P.parseModules text+  return (Just inputFile, text) +loadPrelude :: Either String (String, String, P.Environment)+loadPrelude = +  case P.parseModulesFromFiles [(Nothing, P.prelude)] of+    Left parseError -> Left (show parseError)+    Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) []+ compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment)) compile opts inputFiles = do-  modules <- readInput inputFiles+  modules <- P.parseModulesFromFiles <$> readInput inputFiles   case modules of     Left parseError ->       return (Left $ show parseError)-    Right ms -> return $ P.compile opts ms []+    Right ms -> return $ P.compile opts (map snd ms) []  assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO () assert preludeExterns opts inputFile f = do@@ -79,10 +86,8 @@  main :: IO () main = do-  prelude <- P.preludeFilename-  putStrLn "Compiling Prelude"-  preludeResult <- compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) [prelude]-  case preludeResult of+  putStrLn "Compiling Prelude" +  case loadPrelude of     Left err -> putStrLn err >> exitFailure     Right (preludeJs, exts, _) -> do       tmp <- getTemporaryDirectory