git.iko.soy/rowtype-yoga/purescript-native
on 6206aed help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/CaseDeclarations.hs
62 lines 2.2 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.CaseDeclarations
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Language.PureScript.CaseDeclarations (
16 desugarCases
17) where
19import Data.List (groupBy)
20import Control.Monad (join, unless)
21import Control.Monad.Error.Class
22import Language.PureScript.Names
23import Language.PureScript.Values
24import Language.PureScript.Declarations
26desugarCases :: [Declaration] -> Either String [Declaration]
27desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
29inSameGroup :: Declaration -> Declaration -> Bool
30inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
31inSameGroup _ _ = False
33toDecls :: [Declaration] -> Either String [Declaration]
34toDecls d@[ValueDeclaration _ [] Nothing _] = return d
35toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
36 let tuples = map toTuple ds
37 unless (all ((== map length bs) . map length . fst) tuples) $
38 throwError $ "Argument list lengths differ in declaration " ++ show ident
39 return [makeCaseDeclaration ident tuples]
40toDecls ds = return ds
42toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
43toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
44toTuple _ = error "Not a value declaration"
46makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
47makeCaseDeclaration ident alternatives =
48 let
49 argPattern = map length . fst . head $ alternatives
50 args = map (map (('_' :) . show)) $ toArgs argPattern
51 vars = concatMap (map (\arg -> Var (Qualified global (Ident arg)))) args
52 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
53 value = foldr (\args' ret -> Abs (map Ident args') ret) (Case vars binders) args
54 in
55 ValueDeclaration ident [] Nothing value
57toArgs :: [Int] -> [[Int]]
58toArgs = go 1
59 where
60 go _ [] = []
61 go start (n:ns) = [start..start + n - 1] : go (start + n) ns