Commit fd6cf61a authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Autocommit on sam. oct. 21 18:36:53 CEST 2017

parent bef5bb93
#!/bin/bash
git add -A
git commit -m "Autocommit on $(date)"
......@@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: curly-core
version: 0.2.5
version: 0.2.6.2
-- synopsis:
-- description:
license: MIT
......
......@@ -56,15 +56,21 @@ instance NFData (Symbol s) where
rnf (Argument n) = rnf n
rnf (Builtin _ b) = rnf b
data Strictness = Delayed Strictness [Strictness]
| WHNF (Builtin:+:Int) [Strictness]
type ExprStrictness = ([Strictness],Strictness)
data Strictness = Delayed ExprStrictness
| WHNF (Builtin:+:Int) [ExprStrictness]
deriving (Eq,Ord,Show,Generic)
instance Serializable Strictness
instance Format Strictness
type ExprStrictness = ([Strictness],Strictness)
strictnessArg :: Traversal' Strictness Int
strictnessArg k (WHNF (Right n) sts) = k n <&> \n' -> WHNF (Right n') sts
strictnessArg k x = pure x
strictnessArg :: Traversal (Int,Int) Int Strictness Strictness
strictnessArg k = descend 0
where descend n (WHNF (Right n') ests) =
WHNF . Right <$> k (n,n') <*> traverse (descendE n) ests
descend n (WHNF s ests) = WHNF s <$> traverse (descendE n) ests
descend n (Delayed est) = Delayed <$> descendE (n+1) est
descendE n (sts,st) = (,) <$> traverse (descend n) sts
<*> descend n st
{- | An annotated node
......@@ -396,7 +402,17 @@ instance Identifier s => Annotated (AnnExpr s) s where
exprType (Pure (Builtin t _)) = (t,zero)
exprStrictness (Join ann) = _strictness ann
exprStrictness (Pure (Argument n)) = pure (WHNF (Right n) [])
exprStrictness (Pure (Builtin _ b)) = pure (WHNF (Left b) [])
exprStrictness (Pure (Builtin _ b)) = pure $ case b of
B_AddInt -> binOp B_AddInt
B_MulInt -> binOp B_MulInt
B_DivInt -> binOp B_DivInt
B_SubInt -> binOp B_SubInt
B_AddString -> binOp B_AddString
b -> WHNF (Left b) []
where binOp b = Delayed $ pure $ Delayed $ do
let arg n = WHNF (Right n) []
tell [arg 0, arg 1]
pure (WHNF (Left b) [pure (arg 1), pure (arg 0)])
nameProp :: (forall b. AnnNode s b -> a) -> (AnnExpr s -> a) -> NameExpr s -> a
nameProp np anp = fix $ \nnp a -> case a^..i'NameNode of
......@@ -418,11 +434,10 @@ t'exprType = fix $ \node -> from i'NameNode.(t'Join.annType
argType _ (Argument n) = pure (Argument n)
lambdaAnns :: forall e s. Annotated e s => e -> (Int,Int,Map (Symbol s) Int,ExprType s,ExprStrictness)
lambdaAnns e = (i,m,r,lambdaType (exprType e),pure (Delayed st sts))
lambdaAnns e = (i,m,r,lambdaType (exprType e),pure (Delayed (exprStrictness e)))
where i = Right (Lambda () (exprId e))^..shape
m = exprMass e + 1
r = delete (Argument 0) (exprRefs e) & ascList.each.l'1.argument %~ subtract 1
(sts,st) = exprStrictness e
lambdaType :: forall s. Identifier s => ExprType s -> ExprType s
lambdaType (te,isC) = (te',isC || isComplexType te')
......@@ -433,15 +448,16 @@ applyAnns a b = (i,m,r,applyType (exprType a) (exprType b),st)
where i = Right (Apply (exprId a) (exprId b))^..shape
m = exprMass a + exprMass b + 1
r = exprRefs a *+ exprRefs b
applyStrictness sa sb = case sa of
Delayed st sts -> traverse_ liftArg sts >> liftArg st
WHNF x l -> pure (WHNF x (l+[sb]))
applyStrictness esb sa = case sa of
Delayed (sts,st) -> do tell =<< traverse liftArg sts
liftArg st
WHNF x l -> pure (WHNF x (l+[esb]))
where liftArg = liftArg' 0
liftArg' n (Delayed st sts) = Delayed<$>liftArg' (n+1) st<*>traverse (liftArg' (n+1)) sts
liftArg' n (WHNF (Right arg) sts) | arg==n = foldl' (\x st -> x >>= \y -> applyStrictness y =<< liftArg' n st)
(pure sb) sts
liftArg' n (WHNF s sts) = WHNF s<$>traverse (liftArg' n) sts
st = join (liftA2 applyStrictness (exprStrictness a) (exprStrictness b))
liftArg' n (Delayed (sts,st)) = curry Delayed<$>traverse (liftArg' (n+1)) sts<*>liftArg' (n+1) st
liftArg' n (WHNF (Right arg) ests) | arg==n = foldl' (\esf esx -> applyStrictness (liftArg' n =<< esx) =<< esf)
esb ests
liftArg' n (WHNF s ests) = pure (WHNF s (map (liftArg' n =<<) ests))
st = applyStrictness (exprStrictness b) =<< exprStrictness a
applyType :: forall s. Identifier s => ExprType s -> ExprType s -> ExprType s
applyType (ta,aIsC) (tb,bIsC) = (tret,aIsC || bIsC || isComplexType tret)
where tret = force ta`par`force tb`par`mapTypePathsMonotonic dropTop tsum
......
......@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: curly
version: 0.52.6
version: 0.53.2
-- synopsis:
-- description:
license: MIT
......@@ -15,10 +15,9 @@ build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
executable curly
main-is: Curly.hs
other-modules: Curly.Style, Curly.UI, Curly.Session, Curly.UI.Options, Curly.Session.Commands, Curly.Session.Commands.Repository, Curly.Session.Commands.Context, Curly.Session.Commands.Common, Curly.Session.Commands.Query, Curly.Session.Commands.Style, Curly.Session.Commands.Navigation, Curly.Session.Commands.VCS, Curly.Session.Commands.Run, Curly.Session.Commands.Key, Language.Syntax.CmdArgs
-- other-modules:
library
default-language: Haskell2010
exposed-modules: Curly.Style, Curly.UI, Curly.Session, Curly.UI.Options, Curly.Session.Commands, Curly.Session.Commands.Repository, Curly.Session.Commands.Context, Curly.Session.Commands.Common, Curly.Session.Commands.Query, Curly.Session.Commands.Style, Curly.Session.Commands.Navigation, Curly.Session.Commands.VCS, Curly.Session.Commands.Run, Curly.Session.Commands.Key, Language.Syntax.CmdArgs
default-extensions: RebindableSyntax
FlexibleInstances
MultiParamTypeClasses
......@@ -33,5 +32,21 @@ executable curly
other-extensions: CPP, ExistentialQuantification, ViewPatterns, TypeFamilies, ScopedTypeVariables, RecursiveDo, DeriveGeneric, NoMonomorphismRestriction
build-depends: base >=4.10 && <4.11,cryptohash >=0.11 && <0.12,curly-core >=0.2 && <0.3,curly-system >=0.2 && <0.3,curly-terminfo >=0.4 && <0.5,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5,directory >=1.3 && <1.4,filepath >=1.4 && <1.5,process >=1.6 && <1.7,readline >=1.0 && <1.1,unix >=2.7 && <2.8
hs-source-dirs: src
executable curly
default-language: Haskell2010
main-is: Curly.hs
hs-source-dirs: exe
other-extensions: CPP, ExistentialQuantification, ViewPatterns, TypeFamilies, ScopedTypeVariables, RecursiveDo, DeriveGeneric, NoMonomorphismRestriction
default-extensions: RebindableSyntax
FlexibleInstances
MultiParamTypeClasses
FlexibleContexts
FunctionalDependencies
TypeOperators
TupleSections
ImplicitParams
GeneralizedNewtypeDeriving
RankNTypes
TypeFamilies
build-depends: base >=4.10 && <4.11,cryptohash >=0.11 && <0.12,curly >=0.53 && <0.54,curly-core >=0.2 && <0.3,curly-system >=0.2 && <0.3,curly-terminfo >=0.4 && <0.5,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5,directory >=1.3 && <1.4,filepath >=1.4 && <1.5,process >=1.6 && <1.7,readline >=1.0 && <1.1,unix >=2.7 && <2.8
......@@ -59,6 +59,7 @@ commands = [
("why",whyCmd),
("how",howCmd),
("what",whatCmd),
("whence",whenceCmd),
("compareTypes",compareTypesCmd),
("showInstances",showInstancesCmd),
("where",whereCmd)]),
......
......@@ -10,7 +10,7 @@ import Curly.Style
import Language.Format hiding (space)
import Curly.Session.Commands.Common
whereCmd,whyCmd,whatCmd,howCmd :: Interactive Command
whereCmd,whyCmd,whenceCmd,whatCmd,howCmd :: Interactive Command
viewCmd doc onExpr onPath showV = withDoc doc . fill False $ (several "'s" >> viewSym) <+? viewPath
where viewPath = nbsp >> do
......@@ -35,6 +35,14 @@ whyDoc = unlines [
whyCmd = viewCmd whyDoc zero (const zero) $ \_ (by leafDoc -> d) ->
setupTermFromEnv >>= \t -> withStyle (serveStrLn $ docString t d)
whenceDoc = unlines [
"{section {title Show Function Strictness}"
,"{p {em Usage:} whence PATH {em OR} whence's NAME}"
,"{p Show the strictness for the function at PATH, or of the symbol NAME.}}"
]
whenceCmd = viewCmd whenceDoc zero (const zero) $ \_ (by leafVal -> v) ->
serveStrLn (show (exprStrictness v))
howDoc = unlines [
"{section {title Show Function Implementation}"
,"{p {em Usage:} how PATH {em OR} how's EXPR}"
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment